Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1 | =head1 NAME |
| 2 | |
| 3 | Git - Perl interface to the Git version control system |
| 4 | |
| 5 | =cut |
| 6 | |
| 7 | |
| 8 | package Git; |
| 9 | |
Ævar Arnfjörð Bjarmason | d48b284 | 2010-09-24 20:00:52 +0000 | [diff] [blame] | 10 | use 5.008; |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 11 | use strict; |
| 12 | |
| 13 | |
| 14 | BEGIN { |
| 15 | |
| 16 | our ($VERSION, @ISA, @EXPORT, @EXPORT_OK); |
| 17 | |
| 18 | # Totally unstable API. |
| 19 | $VERSION = '0.01'; |
| 20 | |
| 21 | |
| 22 | =head1 SYNOPSIS |
| 23 | |
| 24 | use Git; |
| 25 | |
| 26 | my $version = Git::command_oneline('version'); |
| 27 | |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 28 | git_cmd_try { Git::command_noisy('update-server-info') } |
| 29 | '%s failed w/ code %d'; |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 30 | |
| 31 | my $repo = Git->repository (Directory => '/srv/git/cogito.git'); |
| 32 | |
| 33 | |
| 34 | my @revs = $repo->command('rev-list', '--since=last monday', '--all'); |
| 35 | |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 36 | my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all'); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 37 | my $lastrev = <$fh>; chomp $lastrev; |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 38 | $repo->command_close_pipe($fh, $c); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 39 | |
Petr Baudis | d43ba46 | 2006-06-24 04:34:49 +0200 | [diff] [blame] | 40 | my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ], |
| 41 | STDERR => 0 ); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 42 | |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 43 | my $sha1 = $repo->hash_and_insert_object('file.txt'); |
| 44 | my $tempfile = tempfile(); |
| 45 | my $size = $repo->cat_blob($sha1, $tempfile); |
| 46 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 47 | =cut |
| 48 | |
| 49 | |
| 50 | require Exporter; |
| 51 | |
| 52 | @ISA = qw(Exporter); |
| 53 | |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 54 | @EXPORT = qw(git_cmd_try); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 55 | |
| 56 | # Methods which can be called as standalone functions as well: |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 57 | @EXPORT_OK = qw(command command_oneline command_noisy |
| 58 | command_output_pipe command_input_pipe command_close_pipe |
Adam Roben | d1a29af | 2008-05-23 16:19:39 +0200 | [diff] [blame] | 59 | command_bidi_pipe command_close_bidi_pipe |
Markus Heidelberg | 89a56bf | 2009-04-05 04:15:16 +0200 | [diff] [blame] | 60 | version exec_path html_path hash_object git_cmd_try |
Sven Strickroth | 38ecf3a | 2012-12-18 01:28:45 +0100 | [diff] [blame] | 61 | remote_refs prompt |
Ben Walton | 68868ff | 2013-02-09 21:46:56 +0000 | [diff] [blame] | 62 | get_tz_offset |
Michal Nazarewicz | 52dce6d | 2013-02-12 15:02:32 +0100 | [diff] [blame] | 63 | credential credential_read credential_write |
Kyle J. McKay | 4e63dcc | 2013-07-06 21:20:48 -0700 | [diff] [blame] | 64 | temp_acquire temp_is_locked temp_release temp_reset temp_path); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 65 | |
| 66 | |
| 67 | =head1 DESCRIPTION |
| 68 | |
| 69 | This module provides Perl scripts easy way to interface the Git version control |
| 70 | system. The modules have an easy and well-tested way to call arbitrary Git |
| 71 | commands; in the future, the interface will also provide specialized methods |
| 72 | for doing easily operations which are not totally trivial to do over |
| 73 | the generic command interface. |
| 74 | |
| 75 | While some commands can be executed outside of any context (e.g. 'version' |
Nicolas Pitre | 5c94f87 | 2007-01-12 16:01:46 -0500 | [diff] [blame] | 76 | or 'init'), most operations require a repository context, which in practice |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 77 | means getting an instance of the Git object using the repository() constructor. |
| 78 | (In the future, we will also get a new_repository() constructor.) All commands |
| 79 | called as methods of the object are then executed in the context of the |
| 80 | repository. |
| 81 | |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 82 | Part of the "repository state" is also information about path to the attached |
| 83 | working copy (unless you work with a bare repository). You can also navigate |
| 84 | inside of the working copy using the C<wc_chdir()> method. (Note that |
| 85 | the repository object is self-contained and will not change working directory |
| 86 | of your process.) |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 87 | |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 88 | TODO: In the future, we might also do |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 89 | |
| 90 | my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master'); |
| 91 | $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/'); |
| 92 | my @refs = $remoterepo->refs(); |
| 93 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 94 | Currently, the module merely wraps calls to external Git tools. In the future, |
| 95 | it will provide a much faster way to interact with Git by linking directly |
| 96 | to libgit. This should be completely opaque to the user, though (performance |
Abhijit Menon-Sen | 9751a32 | 2008-08-05 07:36:16 +0530 | [diff] [blame] | 97 | increase notwithstanding). |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 98 | |
| 99 | =cut |
| 100 | |
| 101 | |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 102 | use Carp qw(carp croak); # but croak is bad - throw instead |
Petr Baudis | 97b16c0 | 2006-06-24 04:34:42 +0200 | [diff] [blame] | 103 | use Error qw(:try); |
Masatake Osanai | 48d9e6a | 2011-02-15 07:13:04 +0900 | [diff] [blame] | 104 | use Cwd qw(abs_path cwd); |
Adam Roben | d1a29af | 2008-05-23 16:19:39 +0200 | [diff] [blame] | 105 | use IPC::Open2 qw(open2); |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 106 | use Fcntl qw(SEEK_SET SEEK_CUR); |
Ben Walton | 75f7b5d | 2013-02-09 21:46:57 +0000 | [diff] [blame] | 107 | use Time::Local qw(timegm); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 108 | } |
| 109 | |
| 110 | |
| 111 | =head1 CONSTRUCTORS |
| 112 | |
| 113 | =over 4 |
| 114 | |
| 115 | =item repository ( OPTIONS ) |
| 116 | |
| 117 | =item repository ( DIRECTORY ) |
| 118 | |
| 119 | =item repository () |
| 120 | |
| 121 | Construct a new repository object. |
| 122 | C<OPTIONS> are passed in a hash like fashion, using key and value pairs. |
| 123 | Possible options are: |
| 124 | |
| 125 | B<Repository> - Path to the Git repository. |
| 126 | |
| 127 | B<WorkingCopy> - Path to the associated working copy; not strictly required |
| 128 | as many commands will happily crunch on a bare repository. |
| 129 | |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 130 | B<WorkingSubdir> - Subdirectory in the working copy to work inside. |
| 131 | Just left undefined if you do not want to limit the scope of operations. |
| 132 | |
| 133 | B<Directory> - Path to the Git working directory in its usual setup. |
| 134 | The C<.git> directory is searched in the directory and all the parent |
| 135 | directories; if found, C<WorkingCopy> is set to the directory containing |
| 136 | it and C<Repository> to the C<.git> directory itself. If no C<.git> |
| 137 | directory was found, the C<Directory> is assumed to be a bare repository, |
| 138 | C<Repository> is set to point at it and C<WorkingCopy> is left undefined. |
| 139 | If the C<$GIT_DIR> environment variable is set, things behave as expected |
| 140 | as well. |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 141 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 142 | You should not use both C<Directory> and either of C<Repository> and |
| 143 | C<WorkingCopy> - the results of that are undefined. |
| 144 | |
| 145 | Alternatively, a directory path may be passed as a single scalar argument |
| 146 | to the constructor; it is equivalent to setting only the C<Directory> option |
| 147 | field. |
| 148 | |
| 149 | Calling the constructor with no options whatsoever is equivalent to |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 150 | calling it with C<< Directory => '.' >>. In general, if you are building |
| 151 | a standard porcelain command, simply doing C<< Git->repository() >> should |
| 152 | do the right thing and setup the object to reflect exactly where the user |
| 153 | is right now. |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 154 | |
| 155 | =cut |
| 156 | |
| 157 | sub repository { |
| 158 | my $class = shift; |
| 159 | my @args = @_; |
| 160 | my %opts = (); |
| 161 | my $self; |
| 162 | |
| 163 | if (defined $args[0]) { |
| 164 | if ($#args % 2 != 1) { |
| 165 | # Not a hash. |
Petr Baudis | 97b16c0 | 2006-06-24 04:34:42 +0200 | [diff] [blame] | 166 | $#args == 0 or throw Error::Simple("bad usage"); |
| 167 | %opts = ( Directory => $args[0] ); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 168 | } else { |
| 169 | %opts = @args; |
| 170 | } |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 171 | } |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 172 | |
Philippe Bruhat (BooK) | 11b8a41 | 2008-12-29 01:25:00 +0100 | [diff] [blame] | 173 | if (not defined $opts{Repository} and not defined $opts{WorkingCopy} |
| 174 | and not defined $opts{Directory}) { |
| 175 | $opts{Directory} = '.'; |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 176 | } |
| 177 | |
Philippe Bruhat (BooK) | 11b8a41 | 2008-12-29 01:25:00 +0100 | [diff] [blame] | 178 | if (defined $opts{Directory}) { |
Philippe Bruhat (BooK) | 64abcc4 | 2010-06-18 01:47:31 +0200 | [diff] [blame] | 179 | -d $opts{Directory} or throw Error::Simple("Directory not found: $opts{Directory} $!"); |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 180 | |
| 181 | my $search = Git->repository(WorkingCopy => $opts{Directory}); |
| 182 | my $dir; |
| 183 | try { |
| 184 | $dir = $search->command_oneline(['rev-parse', '--git-dir'], |
| 185 | STDERR => 0); |
| 186 | } catch Git::Error::Command with { |
| 187 | $dir = undef; |
| 188 | }; |
| 189 | |
| 190 | if ($dir) { |
Johannes Schindelin | 888ab71 | 2016-01-26 15:34:35 +0100 | [diff] [blame] | 191 | _verify_require(); |
| 192 | File::Spec->file_name_is_absolute($dir) or $dir = $opts{Directory} . '/' . $dir; |
Frank Lichtenheld | fe53bbc | 2009-05-07 15:41:28 +0200 | [diff] [blame] | 193 | $opts{Repository} = abs_path($dir); |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 194 | |
| 195 | # If --git-dir went ok, this shouldn't die either. |
| 196 | my $prefix = $search->command_oneline('rev-parse', '--show-prefix'); |
| 197 | $dir = abs_path($opts{Directory}) . '/'; |
| 198 | if ($prefix) { |
| 199 | if (substr($dir, -length($prefix)) ne $prefix) { |
| 200 | throw Error::Simple("rev-parse confused me - $dir does not have trailing $prefix"); |
| 201 | } |
| 202 | substr($dir, -length($prefix)) = ''; |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 203 | } |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 204 | $opts{WorkingCopy} = $dir; |
| 205 | $opts{WorkingSubdir} = $prefix; |
| 206 | |
| 207 | } else { |
| 208 | # A bare repository? Let's see... |
| 209 | $dir = $opts{Directory}; |
| 210 | |
| 211 | unless (-d "$dir/refs" and -d "$dir/objects" and -e "$dir/HEAD") { |
Junio C Hamano | 9517e6b | 2010-02-03 21:23:18 -0800 | [diff] [blame] | 212 | # Mimic git-rev-parse --git-dir error message: |
Richard Hartmann | f66bc5f | 2008-12-22 00:17:32 +0100 | [diff] [blame] | 213 | throw Error::Simple("fatal: Not a git repository: $dir"); |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 214 | } |
| 215 | my $search = Git->repository(Repository => $dir); |
| 216 | try { |
| 217 | $search->command('symbolic-ref', 'HEAD'); |
| 218 | } catch Git::Error::Command with { |
Junio C Hamano | 9517e6b | 2010-02-03 21:23:18 -0800 | [diff] [blame] | 219 | # Mimic git-rev-parse --git-dir error message: |
Richard Hartmann | f66bc5f | 2008-12-22 00:17:32 +0100 | [diff] [blame] | 220 | throw Error::Simple("fatal: Not a git repository: $dir"); |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 221 | } |
| 222 | |
| 223 | $opts{Repository} = abs_path($dir); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 224 | } |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 225 | |
| 226 | delete $opts{Directory}; |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 227 | } |
| 228 | |
Junio C Hamano | 81a7173 | 2006-09-02 22:58:48 -0700 | [diff] [blame] | 229 | $self = { opts => \%opts }; |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 230 | bless $self, $class; |
| 231 | } |
| 232 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 233 | =back |
| 234 | |
| 235 | =head1 METHODS |
| 236 | |
| 237 | =over 4 |
| 238 | |
| 239 | =item command ( COMMAND [, ARGUMENTS... ] ) |
| 240 | |
Petr Baudis | d43ba46 | 2006-06-24 04:34:49 +0200 | [diff] [blame] | 241 | =item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) |
| 242 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 243 | Execute the given Git C<COMMAND> (specify it without the 'git-' |
| 244 | prefix), optionally with the specified extra C<ARGUMENTS>. |
| 245 | |
Petr Baudis | d43ba46 | 2006-06-24 04:34:49 +0200 | [diff] [blame] | 246 | The second more elaborate form can be used if you want to further adjust |
| 247 | the command execution. Currently, only one option is supported: |
| 248 | |
| 249 | B<STDERR> - How to deal with the command's error output. By default (C<undef>) |
| 250 | it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause |
| 251 | it to be thrown away. If you want to process it, you can get it in a filehandle |
| 252 | you specify, but you must be extremely careful; if the error output is not |
| 253 | very short and you want to read it in the same process as where you called |
| 254 | C<command()>, you are set up for a nice deadlock! |
| 255 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 256 | The method can be called without any instance or on a specified Git repository |
| 257 | (in that case the command will be run in the repository context). |
| 258 | |
| 259 | In scalar context, it returns all the command output in a single string |
| 260 | (verbatim). |
| 261 | |
| 262 | In array context, it returns an array containing lines printed to the |
| 263 | command's stdout (without trailing newlines). |
| 264 | |
| 265 | In both cases, the command's stdin and stderr are the same as the caller's. |
| 266 | |
| 267 | =cut |
| 268 | |
| 269 | sub command { |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 270 | my ($fh, $ctx) = command_output_pipe(@_); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 271 | |
| 272 | if (not defined wantarray) { |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 273 | # Nothing to pepper the possible exception with. |
Michal Nazarewicz | 1323dba | 2013-02-12 15:02:30 +0100 | [diff] [blame] | 274 | _cmd_close($ctx, $fh); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 275 | |
| 276 | } elsif (not wantarray) { |
| 277 | local $/; |
| 278 | my $text = <$fh>; |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 279 | try { |
Michal Nazarewicz | 1323dba | 2013-02-12 15:02:30 +0100 | [diff] [blame] | 280 | _cmd_close($ctx, $fh); |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 281 | } catch Git::Error::Command with { |
| 282 | # Pepper with the output: |
| 283 | my $E = shift; |
| 284 | $E->{'-outputref'} = \$text; |
| 285 | throw $E; |
| 286 | }; |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 287 | return $text; |
| 288 | |
| 289 | } else { |
| 290 | my @lines = <$fh>; |
Alex Riesen | 67e4baf | 2007-01-22 15:58:03 +0100 | [diff] [blame] | 291 | defined and chomp for @lines; |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 292 | try { |
Michal Nazarewicz | 1323dba | 2013-02-12 15:02:30 +0100 | [diff] [blame] | 293 | _cmd_close($ctx, $fh); |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 294 | } catch Git::Error::Command with { |
| 295 | my $E = shift; |
| 296 | $E->{'-outputref'} = \@lines; |
| 297 | throw $E; |
| 298 | }; |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 299 | return @lines; |
| 300 | } |
| 301 | } |
| 302 | |
| 303 | |
| 304 | =item command_oneline ( COMMAND [, ARGUMENTS... ] ) |
| 305 | |
Petr Baudis | d43ba46 | 2006-06-24 04:34:49 +0200 | [diff] [blame] | 306 | =item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) |
| 307 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 308 | Execute the given C<COMMAND> in the same way as command() |
| 309 | does but always return a scalar string containing the first line |
| 310 | of the command's standard output. |
| 311 | |
| 312 | =cut |
| 313 | |
| 314 | sub command_oneline { |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 315 | my ($fh, $ctx) = command_output_pipe(@_); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 316 | |
| 317 | my $line = <$fh>; |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 318 | defined $line and chomp $line; |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 319 | try { |
Michal Nazarewicz | 1323dba | 2013-02-12 15:02:30 +0100 | [diff] [blame] | 320 | _cmd_close($ctx, $fh); |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 321 | } catch Git::Error::Command with { |
| 322 | # Pepper with the output: |
| 323 | my $E = shift; |
| 324 | $E->{'-outputref'} = \$line; |
| 325 | throw $E; |
| 326 | }; |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 327 | return $line; |
| 328 | } |
| 329 | |
| 330 | |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 331 | =item command_output_pipe ( COMMAND [, ARGUMENTS... ] ) |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 332 | |
Petr Baudis | d43ba46 | 2006-06-24 04:34:49 +0200 | [diff] [blame] | 333 | =item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) |
| 334 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 335 | Execute the given C<COMMAND> in the same way as command() |
| 336 | does but return a pipe filehandle from which the command output can be |
| 337 | read. |
| 338 | |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 339 | The function can return C<($pipe, $ctx)> in array context. |
| 340 | See C<command_close_pipe()> for details. |
| 341 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 342 | =cut |
| 343 | |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 344 | sub command_output_pipe { |
| 345 | _command_common_pipe('-|', @_); |
| 346 | } |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 347 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 348 | |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 349 | =item command_input_pipe ( COMMAND [, ARGUMENTS... ] ) |
| 350 | |
Petr Baudis | d43ba46 | 2006-06-24 04:34:49 +0200 | [diff] [blame] | 351 | =item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) |
| 352 | |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 353 | Execute the given C<COMMAND> in the same way as command_output_pipe() |
| 354 | does but return an input pipe filehandle instead; the command output |
| 355 | is not captured. |
| 356 | |
| 357 | The function can return C<($pipe, $ctx)> in array context. |
| 358 | See C<command_close_pipe()> for details. |
| 359 | |
| 360 | =cut |
| 361 | |
| 362 | sub command_input_pipe { |
| 363 | _command_common_pipe('|-', @_); |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 364 | } |
| 365 | |
| 366 | |
| 367 | =item command_close_pipe ( PIPE [, CTX ] ) |
| 368 | |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 369 | Close the C<PIPE> as returned from C<command_*_pipe()>, checking |
Pavel Roskin | 3dff537 | 2007-02-03 23:49:16 -0500 | [diff] [blame] | 370 | whether the command finished successfully. The optional C<CTX> argument |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 371 | is required if you want to see the command name in the error message, |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 372 | and it is the second value returned by C<command_*_pipe()> when |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 373 | called in array context. The call idiom is: |
| 374 | |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 375 | my ($fh, $ctx) = $r->command_output_pipe('status'); |
| 376 | while (<$fh>) { ... } |
| 377 | $r->command_close_pipe($fh, $ctx); |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 378 | |
| 379 | Note that you should not rely on whatever actually is in C<CTX>; |
| 380 | currently it is simply the command name but in future the context might |
| 381 | have more complicated structure. |
| 382 | |
| 383 | =cut |
| 384 | |
| 385 | sub command_close_pipe { |
| 386 | my ($self, $fh, $ctx) = _maybe_self(@_); |
| 387 | $ctx ||= '<unknown>'; |
Michal Nazarewicz | 1323dba | 2013-02-12 15:02:30 +0100 | [diff] [blame] | 388 | _cmd_close($ctx, $fh); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 389 | } |
| 390 | |
Adam Roben | d1a29af | 2008-05-23 16:19:39 +0200 | [diff] [blame] | 391 | =item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] ) |
| 392 | |
| 393 | Execute the given C<COMMAND> in the same way as command_output_pipe() |
| 394 | does but return both an input pipe filehandle and an output pipe filehandle. |
| 395 | |
Li Peng | 832c0e5 | 2016-05-06 20:36:46 +0800 | [diff] [blame] | 396 | The function will return C<($pid, $pipe_in, $pipe_out, $ctx)>. |
Adam Roben | d1a29af | 2008-05-23 16:19:39 +0200 | [diff] [blame] | 397 | See C<command_close_bidi_pipe()> for details. |
| 398 | |
| 399 | =cut |
| 400 | |
| 401 | sub command_bidi_pipe { |
| 402 | my ($pid, $in, $out); |
Masatake Osanai | 48d9e6a | 2011-02-15 07:13:04 +0900 | [diff] [blame] | 403 | my ($self) = _maybe_self(@_); |
| 404 | local %ENV = %ENV; |
| 405 | my $cwd_save = undef; |
| 406 | if ($self) { |
| 407 | shift; |
| 408 | $cwd_save = cwd(); |
| 409 | _setup_git_cmd_env($self); |
| 410 | } |
Adam Roben | d1a29af | 2008-05-23 16:19:39 +0200 | [diff] [blame] | 411 | $pid = open2($in, $out, 'git', @_); |
Masatake Osanai | 48d9e6a | 2011-02-15 07:13:04 +0900 | [diff] [blame] | 412 | chdir($cwd_save) if $cwd_save; |
Adam Roben | d1a29af | 2008-05-23 16:19:39 +0200 | [diff] [blame] | 413 | return ($pid, $in, $out, join(' ', @_)); |
| 414 | } |
| 415 | |
| 416 | =item command_close_bidi_pipe ( PID, PIPE_IN, PIPE_OUT [, CTX] ) |
| 417 | |
| 418 | Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>, |
| 419 | checking whether the command finished successfully. The optional C<CTX> |
| 420 | argument is required if you want to see the command name in the error message, |
| 421 | and it is the fourth value returned by C<command_bidi_pipe()>. The call idiom |
| 422 | is: |
| 423 | |
| 424 | my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check'); |
Michal Nazarewicz | 8a2cc51 | 2013-02-07 15:01:18 +0100 | [diff] [blame] | 425 | print $out "000000000\n"; |
Adam Roben | d1a29af | 2008-05-23 16:19:39 +0200 | [diff] [blame] | 426 | while (<$in>) { ... } |
| 427 | $r->command_close_bidi_pipe($pid, $in, $out, $ctx); |
| 428 | |
| 429 | Note that you should not rely on whatever actually is in C<CTX>; |
| 430 | currently it is simply the command name but in future the context might |
| 431 | have more complicated structure. |
| 432 | |
Michal Nazarewicz | f4c0035 | 2013-02-12 15:02:31 +0100 | [diff] [blame] | 433 | C<PIPE_IN> and C<PIPE_OUT> may be C<undef> if they have been closed prior to |
| 434 | calling this function. This may be useful in a query-response type of |
| 435 | commands where caller first writes a query and later reads response, eg: |
| 436 | |
| 437 | my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check'); |
| 438 | print $out "000000000\n"; |
| 439 | close $out; |
| 440 | while (<$in>) { ... } |
| 441 | $r->command_close_bidi_pipe($pid, $in, undef, $ctx); |
| 442 | |
| 443 | This idiom may prevent potential dead locks caused by data sent to the output |
| 444 | pipe not being flushed and thus not reaching the executed command. |
| 445 | |
Adam Roben | d1a29af | 2008-05-23 16:19:39 +0200 | [diff] [blame] | 446 | =cut |
| 447 | |
| 448 | sub command_close_bidi_pipe { |
Abhijit Menon-Sen | 108c2aa | 2008-08-04 17:08:27 +0530 | [diff] [blame] | 449 | local $?; |
Michal Nazarewicz | 1bc760a | 2013-02-07 15:01:17 +0100 | [diff] [blame] | 450 | my ($self, $pid, $in, $out, $ctx) = _maybe_self(@_); |
Michal Nazarewicz | f4c0035 | 2013-02-12 15:02:31 +0100 | [diff] [blame] | 451 | _cmd_close($ctx, (grep { defined } ($in, $out))); |
Adam Roben | d1a29af | 2008-05-23 16:19:39 +0200 | [diff] [blame] | 452 | waitpid $pid, 0; |
Adam Roben | d1a29af | 2008-05-23 16:19:39 +0200 | [diff] [blame] | 453 | if ($? >> 8) { |
| 454 | throw Git::Error::Command($ctx, $? >>8); |
| 455 | } |
| 456 | } |
| 457 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 458 | |
| 459 | =item command_noisy ( COMMAND [, ARGUMENTS... ] ) |
| 460 | |
| 461 | Execute the given C<COMMAND> in the same way as command() does but do not |
| 462 | capture the command output - the standard output is not redirected and goes |
| 463 | to the standard output of the caller application. |
| 464 | |
| 465 | While the method is called command_noisy(), you might want to as well use |
| 466 | it for the most silent Git commands which you know will never pollute your |
| 467 | stdout but you want to avoid the overhead of the pipe setup when calling them. |
| 468 | |
| 469 | The function returns only after the command has finished running. |
| 470 | |
| 471 | =cut |
| 472 | |
| 473 | sub command_noisy { |
| 474 | my ($self, $cmd, @args) = _maybe_self(@_); |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 475 | _check_valid_cmd($cmd); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 476 | |
| 477 | my $pid = fork; |
| 478 | if (not defined $pid) { |
Petr Baudis | 97b16c0 | 2006-06-24 04:34:42 +0200 | [diff] [blame] | 479 | throw Error::Simple("fork failed: $!"); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 480 | } elsif ($pid == 0) { |
| 481 | _cmd_exec($self, $cmd, @args); |
| 482 | } |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 483 | if (waitpid($pid, 0) > 0 and $?>>8 != 0) { |
| 484 | throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 485 | } |
| 486 | } |
| 487 | |
| 488 | |
Petr Baudis | 63df97a | 2006-06-24 04:34:36 +0200 | [diff] [blame] | 489 | =item version () |
| 490 | |
| 491 | Return the Git version in use. |
| 492 | |
Petr Baudis | 63df97a | 2006-06-24 04:34:36 +0200 | [diff] [blame] | 493 | =cut |
| 494 | |
Petr Baudis | 18b0fc1 | 2006-09-23 20:20:47 +0200 | [diff] [blame] | 495 | sub version { |
| 496 | my $verstr = command_oneline('--version'); |
| 497 | $verstr =~ s/^git version //; |
| 498 | $verstr; |
| 499 | } |
Petr Baudis | 63df97a | 2006-06-24 04:34:36 +0200 | [diff] [blame] | 500 | |
| 501 | |
Petr Baudis | eca1f6f | 2006-06-24 04:34:31 +0200 | [diff] [blame] | 502 | =item exec_path () |
| 503 | |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 504 | Return path to the Git sub-command executables (the same as |
Petr Baudis | eca1f6f | 2006-06-24 04:34:31 +0200 | [diff] [blame] | 505 | C<git --exec-path>). Useful mostly only internally. |
| 506 | |
Petr Baudis | eca1f6f | 2006-06-24 04:34:31 +0200 | [diff] [blame] | 507 | =cut |
| 508 | |
Petr Baudis | 18b0fc1 | 2006-09-23 20:20:47 +0200 | [diff] [blame] | 509 | sub exec_path { command_oneline('--exec-path') } |
Petr Baudis | eca1f6f | 2006-06-24 04:34:31 +0200 | [diff] [blame] | 510 | |
| 511 | |
Markus Heidelberg | 89a56bf | 2009-04-05 04:15:16 +0200 | [diff] [blame] | 512 | =item html_path () |
| 513 | |
| 514 | Return path to the Git html documentation (the same as |
| 515 | C<git --html-path>). Useful mostly only internally. |
| 516 | |
| 517 | =cut |
| 518 | |
| 519 | sub html_path { command_oneline('--html-path') } |
| 520 | |
Ben Walton | 68868ff | 2013-02-09 21:46:56 +0000 | [diff] [blame] | 521 | |
| 522 | =item get_tz_offset ( TIME ) |
| 523 | |
| 524 | Return the time zone offset from GMT in the form +/-HHMM where HH is |
| 525 | the number of hours from GMT and MM is the number of minutes. This is |
| 526 | the equivalent of what strftime("%z", ...) would provide on a GNU |
| 527 | platform. |
| 528 | |
| 529 | If TIME is not supplied, the current local time is used. |
| 530 | |
| 531 | =cut |
| 532 | |
| 533 | sub get_tz_offset { |
| 534 | # some systmes don't handle or mishandle %z, so be creative. |
| 535 | my $t = shift || time; |
Ben Walton | 75f7b5d | 2013-02-09 21:46:57 +0000 | [diff] [blame] | 536 | my $gm = timegm(localtime($t)); |
| 537 | my $sign = qw( + + - )[ $gm <=> $t ]; |
Ben Walton | 68868ff | 2013-02-09 21:46:56 +0000 | [diff] [blame] | 538 | return sprintf("%s%02d%02d", $sign, (gmtime(abs($t - $gm)))[2,1]); |
| 539 | } |
| 540 | |
| 541 | |
Sven Strickroth | e9263e4 | 2012-12-18 01:28:48 +0100 | [diff] [blame] | 542 | =item prompt ( PROMPT , ISPASSWORD ) |
Sven Strickroth | 38ecf3a | 2012-12-18 01:28:45 +0100 | [diff] [blame] | 543 | |
| 544 | Query user C<PROMPT> and return answer from user. |
| 545 | |
Sven Strickroth | 8f3cab2 | 2012-12-18 01:28:47 +0100 | [diff] [blame] | 546 | Honours GIT_ASKPASS and SSH_ASKPASS environment variables for querying |
| 547 | the user. If no *_ASKPASS variable is set or an error occoured, |
Sven Strickroth | 38ecf3a | 2012-12-18 01:28:45 +0100 | [diff] [blame] | 548 | the terminal is tried as a fallback. |
Sven Strickroth | e9263e4 | 2012-12-18 01:28:48 +0100 | [diff] [blame] | 549 | If C<ISPASSWORD> is set and true, the terminal disables echo. |
Sven Strickroth | 38ecf3a | 2012-12-18 01:28:45 +0100 | [diff] [blame] | 550 | |
| 551 | =cut |
| 552 | |
| 553 | sub prompt { |
Sven Strickroth | e9263e4 | 2012-12-18 01:28:48 +0100 | [diff] [blame] | 554 | my ($prompt, $isPassword) = @_; |
Sven Strickroth | 38ecf3a | 2012-12-18 01:28:45 +0100 | [diff] [blame] | 555 | my $ret; |
| 556 | if (exists $ENV{'GIT_ASKPASS'}) { |
| 557 | $ret = _prompt($ENV{'GIT_ASKPASS'}, $prompt); |
| 558 | } |
Sven Strickroth | 8f3cab2 | 2012-12-18 01:28:47 +0100 | [diff] [blame] | 559 | if (!defined $ret && exists $ENV{'SSH_ASKPASS'}) { |
| 560 | $ret = _prompt($ENV{'SSH_ASKPASS'}, $prompt); |
| 561 | } |
Sven Strickroth | 38ecf3a | 2012-12-18 01:28:45 +0100 | [diff] [blame] | 562 | if (!defined $ret) { |
| 563 | print STDERR $prompt; |
| 564 | STDERR->flush; |
Sven Strickroth | e9263e4 | 2012-12-18 01:28:48 +0100 | [diff] [blame] | 565 | if (defined $isPassword && $isPassword) { |
| 566 | require Term::ReadKey; |
| 567 | Term::ReadKey::ReadMode('noecho'); |
| 568 | $ret = ''; |
| 569 | while (defined(my $key = Term::ReadKey::ReadKey(0))) { |
| 570 | last if $key =~ /[\012\015]/; # \n\r |
| 571 | $ret .= $key; |
| 572 | } |
| 573 | Term::ReadKey::ReadMode('restore'); |
| 574 | print STDERR "\n"; |
| 575 | STDERR->flush; |
| 576 | } else { |
| 577 | chomp($ret = <STDIN>); |
Sven Strickroth | 38ecf3a | 2012-12-18 01:28:45 +0100 | [diff] [blame] | 578 | } |
Sven Strickroth | 38ecf3a | 2012-12-18 01:28:45 +0100 | [diff] [blame] | 579 | } |
| 580 | return $ret; |
| 581 | } |
| 582 | |
| 583 | sub _prompt { |
| 584 | my ($askpass, $prompt) = @_; |
| 585 | return unless length $askpass; |
Sven Strickroth | e9263e4 | 2012-12-18 01:28:48 +0100 | [diff] [blame] | 586 | $prompt =~ s/\n/ /g; |
Sven Strickroth | 38ecf3a | 2012-12-18 01:28:45 +0100 | [diff] [blame] | 587 | my $ret; |
| 588 | open my $fh, "-|", $askpass, $prompt or return; |
| 589 | $ret = <$fh>; |
| 590 | $ret =~ s/[\015\012]//g; # strip \r\n, chomp does not work on all systems (i.e. windows) as expected |
| 591 | close ($fh); |
| 592 | return $ret; |
| 593 | } |
Markus Heidelberg | 89a56bf | 2009-04-05 04:15:16 +0200 | [diff] [blame] | 594 | |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 595 | =item repo_path () |
| 596 | |
| 597 | Return path to the git repository. Must be called on a repository instance. |
| 598 | |
| 599 | =cut |
| 600 | |
| 601 | sub repo_path { $_[0]->{opts}->{Repository} } |
| 602 | |
| 603 | |
| 604 | =item wc_path () |
| 605 | |
| 606 | Return path to the working copy. Must be called on a repository instance. |
| 607 | |
| 608 | =cut |
| 609 | |
| 610 | sub wc_path { $_[0]->{opts}->{WorkingCopy} } |
| 611 | |
| 612 | |
| 613 | =item wc_subdir () |
| 614 | |
| 615 | Return path to the subdirectory inside of a working copy. Must be called |
| 616 | on a repository instance. |
| 617 | |
| 618 | =cut |
| 619 | |
| 620 | sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' } |
| 621 | |
| 622 | |
| 623 | =item wc_chdir ( SUBDIR ) |
| 624 | |
| 625 | Change the working copy subdirectory to work within. The C<SUBDIR> is |
| 626 | relative to the working copy root directory (not the current subdirectory). |
| 627 | Must be called on a repository instance attached to a working copy |
| 628 | and the directory must exist. |
| 629 | |
| 630 | =cut |
| 631 | |
| 632 | sub wc_chdir { |
| 633 | my ($self, $subdir) = @_; |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 634 | $self->wc_path() |
| 635 | or throw Error::Simple("bare repository"); |
| 636 | |
| 637 | -d $self->wc_path().'/'.$subdir |
Philippe Bruhat (BooK) | 64abcc4 | 2010-06-18 01:47:31 +0200 | [diff] [blame] | 638 | or throw Error::Simple("subdir not found: $subdir $!"); |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 639 | # Of course we will not "hold" the subdirectory so anyone |
| 640 | # can delete it now and we will never know. But at least we tried. |
| 641 | |
| 642 | $self->{opts}->{WorkingSubdir} = $subdir; |
| 643 | } |
| 644 | |
| 645 | |
Petr Baudis | dc2613d | 2006-07-03 22:47:55 +0200 | [diff] [blame] | 646 | =item config ( VARIABLE ) |
| 647 | |
Tom Prince | e0d10e1 | 2007-01-28 16:16:53 -0800 | [diff] [blame] | 648 | Retrieve the configuration C<VARIABLE> in the same manner as C<config> |
Petr Baudis | dc2613d | 2006-07-03 22:47:55 +0200 | [diff] [blame] | 649 | does. In scalar context requires the variable to be set only one time |
| 650 | (exception is thrown otherwise), in array context returns allows the |
| 651 | variable to be set multiple times and returns all the values. |
| 652 | |
Petr Baudis | dc2613d | 2006-07-03 22:47:55 +0200 | [diff] [blame] | 653 | =cut |
| 654 | |
| 655 | sub config { |
Junio C Hamano | 6942a3d | 2011-10-18 11:47:01 +0200 | [diff] [blame] | 656 | return _config_common({}, @_); |
| 657 | } |
| 658 | |
| 659 | |
| 660 | =item config_bool ( VARIABLE ) |
| 661 | |
| 662 | Retrieve the bool configuration C<VARIABLE>. The return value |
| 663 | is usable as a boolean in perl (and C<undef> if it's not defined, |
| 664 | of course). |
| 665 | |
| 666 | =cut |
| 667 | |
| 668 | sub config_bool { |
| 669 | my $val = scalar _config_common({'kind' => '--bool'}, @_); |
| 670 | |
| 671 | # Do not rewrite this as return (defined $val && $val eq 'true') |
| 672 | # as some callers do care what kind of falsehood they receive. |
| 673 | if (!defined $val) { |
| 674 | return undef; |
| 675 | } else { |
| 676 | return $val eq 'true'; |
| 677 | } |
| 678 | } |
| 679 | |
| 680 | |
| 681 | =item config_path ( VARIABLE ) |
| 682 | |
| 683 | Retrieve the path configuration C<VARIABLE>. The return value |
| 684 | is an expanded path or C<undef> if it's not defined. |
| 685 | |
| 686 | =cut |
| 687 | |
| 688 | sub config_path { |
| 689 | return _config_common({'kind' => '--path'}, @_); |
| 690 | } |
| 691 | |
| 692 | |
| 693 | =item config_int ( VARIABLE ) |
| 694 | |
| 695 | Retrieve the integer configuration C<VARIABLE>. The return value |
| 696 | is simple decimal number. An optional value suffix of 'k', 'm', |
| 697 | or 'g' in the config file will cause the value to be multiplied |
| 698 | by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output. |
Alexander Kuleshov | ef2956a | 2015-02-18 23:32:20 +0600 | [diff] [blame] | 699 | It would return C<undef> if configuration variable is not defined. |
Junio C Hamano | 6942a3d | 2011-10-18 11:47:01 +0200 | [diff] [blame] | 700 | |
| 701 | =cut |
| 702 | |
| 703 | sub config_int { |
| 704 | return scalar _config_common({'kind' => '--int'}, @_); |
| 705 | } |
| 706 | |
| 707 | # Common subroutine to implement bulk of what the config* family of methods |
Alexander Kuleshov | ef2956a | 2015-02-18 23:32:20 +0600 | [diff] [blame] | 708 | # do. This currently wraps command('config') so it is not so fast. |
Junio C Hamano | 6942a3d | 2011-10-18 11:47:01 +0200 | [diff] [blame] | 709 | sub _config_common { |
| 710 | my ($opts) = shift @_; |
Frank Lichtenheld | c2e357c | 2008-03-14 18:29:28 +0100 | [diff] [blame] | 711 | my ($self, $var) = _maybe_self(@_); |
Petr Baudis | dc2613d | 2006-07-03 22:47:55 +0200 | [diff] [blame] | 712 | |
| 713 | try { |
Junio C Hamano | 6942a3d | 2011-10-18 11:47:01 +0200 | [diff] [blame] | 714 | my @cmd = ('config', $opts->{'kind'} ? $opts->{'kind'} : ()); |
Frank Lichtenheld | c2e357c | 2008-03-14 18:29:28 +0100 | [diff] [blame] | 715 | unshift @cmd, $self if $self; |
Petr Baudis | dc2613d | 2006-07-03 22:47:55 +0200 | [diff] [blame] | 716 | if (wantarray) { |
Frank Lichtenheld | c2e357c | 2008-03-14 18:29:28 +0100 | [diff] [blame] | 717 | return command(@cmd, '--get-all', $var); |
Petr Baudis | dc2613d | 2006-07-03 22:47:55 +0200 | [diff] [blame] | 718 | } else { |
Frank Lichtenheld | c2e357c | 2008-03-14 18:29:28 +0100 | [diff] [blame] | 719 | return command_oneline(@cmd, '--get', $var); |
Petr Baudis | dc2613d | 2006-07-03 22:47:55 +0200 | [diff] [blame] | 720 | } |
| 721 | } catch Git::Error::Command with { |
| 722 | my $E = shift; |
| 723 | if ($E->value() == 1) { |
| 724 | # Key not found. |
Lea Wiemann | 32d8050 | 2008-06-01 22:34:47 +0200 | [diff] [blame] | 725 | return; |
Petr Baudis | dc2613d | 2006-07-03 22:47:55 +0200 | [diff] [blame] | 726 | } else { |
| 727 | throw $E; |
| 728 | } |
| 729 | }; |
| 730 | } |
| 731 | |
Junio C Hamano | b4c61ed | 2007-12-05 00:50:23 -0800 | [diff] [blame] | 732 | =item get_colorbool ( NAME ) |
| 733 | |
| 734 | Finds if color should be used for NAMEd operation from the configuration, |
| 735 | and returns boolean (true for "use color", false for "do not use color"). |
| 736 | |
| 737 | =cut |
| 738 | |
| 739 | sub get_colorbool { |
| 740 | my ($self, $var) = @_; |
| 741 | my $stdout_to_tty = (-t STDOUT) ? "true" : "false"; |
| 742 | my $use_color = $self->command_oneline('config', '--get-colorbool', |
| 743 | $var, $stdout_to_tty); |
| 744 | return ($use_color eq 'true'); |
| 745 | } |
| 746 | |
| 747 | =item get_color ( SLOT, COLOR ) |
| 748 | |
| 749 | Finds color for SLOT from the configuration, while defaulting to COLOR, |
| 750 | and returns the ANSI color escape sequence: |
| 751 | |
| 752 | print $repo->get_color("color.interactive.prompt", "underline blue white"); |
| 753 | print "some text"; |
| 754 | print $repo->get_color("", "normal"); |
| 755 | |
| 756 | =cut |
| 757 | |
| 758 | sub get_color { |
| 759 | my ($self, $slot, $default) = @_; |
| 760 | my $color = $self->command_oneline('config', '--get-color', $slot, $default); |
| 761 | if (!defined $color) { |
| 762 | $color = ""; |
| 763 | } |
| 764 | return $color; |
| 765 | } |
| 766 | |
Petr Baudis | 31a92f6 | 2008-07-08 19:48:04 +0200 | [diff] [blame] | 767 | =item remote_refs ( REPOSITORY [, GROUPS [, REFGLOBS ] ] ) |
| 768 | |
| 769 | This function returns a hashref of refs stored in a given remote repository. |
| 770 | The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry |
| 771 | contains the tag object while a C<refname^{}> entry gives the tagged objects. |
| 772 | |
| 773 | C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote> |
Jim Meyering | a7793a7 | 2012-03-28 10:41:54 +0200 | [diff] [blame] | 774 | argument; either a URL or a remote name (if called on a repository instance). |
Petr Baudis | 31a92f6 | 2008-07-08 19:48:04 +0200 | [diff] [blame] | 775 | C<GROUPS> is an optional arrayref that can contain 'tags' to return all the |
| 776 | tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array |
| 777 | of strings containing a shell-like glob to further limit the refs returned in |
| 778 | the hash; the meaning is again the same as the appropriate C<git-ls-remote> |
| 779 | argument. |
| 780 | |
| 781 | This function may or may not be called on a repository instance. In the former |
| 782 | case, remote names as defined in the repository are recognized as repository |
| 783 | specifiers. |
| 784 | |
| 785 | =cut |
| 786 | |
| 787 | sub remote_refs { |
| 788 | my ($self, $repo, $groups, $refglobs) = _maybe_self(@_); |
| 789 | my @args; |
| 790 | if (ref $groups eq 'ARRAY') { |
| 791 | foreach (@$groups) { |
| 792 | if ($_ eq 'heads') { |
| 793 | push (@args, '--heads'); |
| 794 | } elsif ($_ eq 'tags') { |
| 795 | push (@args, '--tags'); |
| 796 | } else { |
| 797 | # Ignore unknown groups for future |
| 798 | # compatibility |
| 799 | } |
| 800 | } |
| 801 | } |
| 802 | push (@args, $repo); |
| 803 | if (ref $refglobs eq 'ARRAY') { |
| 804 | push (@args, @$refglobs); |
| 805 | } |
| 806 | |
| 807 | my @self = $self ? ($self) : (); # Ultra trickery |
| 808 | my ($fh, $ctx) = Git::command_output_pipe(@self, 'ls-remote', @args); |
| 809 | my %refs; |
| 810 | while (<$fh>) { |
| 811 | chomp; |
| 812 | my ($hash, $ref) = split(/\t/, $_, 2); |
| 813 | $refs{$ref} = $hash; |
| 814 | } |
| 815 | Git::command_close_pipe(@self, $fh, $ctx); |
| 816 | return \%refs; |
| 817 | } |
| 818 | |
| 819 | |
Petr Baudis | c7a30e5 | 2006-07-03 22:48:01 +0200 | [diff] [blame] | 820 | =item ident ( TYPE | IDENTSTR ) |
| 821 | |
| 822 | =item ident_person ( TYPE | IDENTSTR | IDENTARRAY ) |
| 823 | |
| 824 | This suite of functions retrieves and parses ident information, as stored |
| 825 | in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus |
| 826 | C<TYPE> can be either I<author> or I<committer>; case is insignificant). |
| 827 | |
Todd Zullinger | 5354a56 | 2008-07-30 13:48:33 -0400 | [diff] [blame] | 828 | The C<ident> method retrieves the ident information from C<git var> |
Petr Baudis | c7a30e5 | 2006-07-03 22:48:01 +0200 | [diff] [blame] | 829 | and either returns it as a scalar string or as an array with the fields parsed. |
| 830 | Alternatively, it can take a prepared ident string (e.g. from the commit |
| 831 | object) and just parse it. |
| 832 | |
| 833 | C<ident_person> returns the person part of the ident - name and email; |
| 834 | it can take the same arguments as C<ident> or the array returned by C<ident>. |
| 835 | |
| 836 | The synopsis is like: |
| 837 | |
| 838 | my ($name, $email, $time_tz) = ident('author'); |
| 839 | "$name <$email>" eq ident_person('author'); |
| 840 | "$name <$email>" eq ident_person($name); |
| 841 | $time_tz =~ /^\d+ [+-]\d{4}$/; |
| 842 | |
Petr Baudis | c7a30e5 | 2006-07-03 22:48:01 +0200 | [diff] [blame] | 843 | =cut |
| 844 | |
| 845 | sub ident { |
Frank Lichtenheld | 4461792 | 2008-03-14 18:29:29 +0100 | [diff] [blame] | 846 | my ($self, $type) = _maybe_self(@_); |
Petr Baudis | c7a30e5 | 2006-07-03 22:48:01 +0200 | [diff] [blame] | 847 | my $identstr; |
| 848 | if (lc $type eq lc 'committer' or lc $type eq lc 'author') { |
Frank Lichtenheld | 4461792 | 2008-03-14 18:29:29 +0100 | [diff] [blame] | 849 | my @cmd = ('var', 'GIT_'.uc($type).'_IDENT'); |
| 850 | unshift @cmd, $self if $self; |
| 851 | $identstr = command_oneline(@cmd); |
Petr Baudis | c7a30e5 | 2006-07-03 22:48:01 +0200 | [diff] [blame] | 852 | } else { |
| 853 | $identstr = $type; |
| 854 | } |
| 855 | if (wantarray) { |
| 856 | return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/; |
| 857 | } else { |
| 858 | return $identstr; |
| 859 | } |
| 860 | } |
| 861 | |
| 862 | sub ident_person { |
Frank Lichtenheld | 4461792 | 2008-03-14 18:29:29 +0100 | [diff] [blame] | 863 | my ($self, @ident) = _maybe_self(@_); |
| 864 | $#ident == 0 and @ident = $self ? $self->ident($ident[0]) : ident($ident[0]); |
Petr Baudis | c7a30e5 | 2006-07-03 22:48:01 +0200 | [diff] [blame] | 865 | return "$ident[0] <$ident[1]>"; |
| 866 | } |
| 867 | |
Remi Lespinet | 8d314d7 | 2015-07-07 15:38:15 +0200 | [diff] [blame] | 868 | =item parse_mailboxes |
| 869 | |
| 870 | Return an array of mailboxes extracted from a string. |
| 871 | |
| 872 | =cut |
| 873 | |
| 874 | sub parse_mailboxes { |
| 875 | my $re_comment = qr/\((?:[^)]*)\)/; |
| 876 | my $re_quote = qr/"(?:[^\"\\]|\\.)*"/; |
| 877 | my $re_word = qr/(?:[^]["\s()<>:;@\\,.]|\\.)+/; |
| 878 | |
| 879 | # divide the string in tokens of the above form |
| 880 | my $re_token = qr/(?:$re_quote|$re_word|$re_comment|\S)/; |
| 881 | my @tokens = map { $_ =~ /\s*($re_token)\s*/g } @_; |
| 882 | |
| 883 | # add a delimiter to simplify treatment for the last mailbox |
| 884 | push @tokens, ","; |
| 885 | |
| 886 | my (@addr_list, @phrase, @address, @comment, @buffer) = (); |
| 887 | foreach my $token (@tokens) { |
| 888 | if ($token =~ /^[,;]$/) { |
| 889 | # if buffer still contains undeterminated strings |
| 890 | # append it at the end of @address or @phrase |
| 891 | if (@address) { |
| 892 | push @address, @buffer; |
| 893 | } else { |
| 894 | push @phrase, @buffer; |
| 895 | } |
| 896 | |
| 897 | my $str_phrase = join ' ', @phrase; |
| 898 | my $str_address = join '', @address; |
| 899 | my $str_comment = join ' ', @comment; |
| 900 | |
| 901 | # quote are necessary if phrase contains |
| 902 | # special characters |
| 903 | if ($str_phrase =~ /[][()<>:;@\\,.\000-\037\177]/) { |
| 904 | $str_phrase =~ s/(^|[^\\])"/$1/g; |
| 905 | $str_phrase = qq["$str_phrase"]; |
| 906 | } |
| 907 | |
| 908 | # add "<>" around the address if necessary |
| 909 | if ($str_address ne "" && $str_phrase ne "") { |
| 910 | $str_address = qq[<$str_address>]; |
| 911 | } |
| 912 | |
| 913 | my $str_mailbox = "$str_phrase $str_address $str_comment"; |
| 914 | $str_mailbox =~ s/^\s*|\s*$//g; |
| 915 | push @addr_list, $str_mailbox if ($str_mailbox); |
| 916 | |
| 917 | @phrase = @address = @comment = @buffer = (); |
| 918 | } elsif ($token =~ /^\(/) { |
| 919 | push @comment, $token; |
| 920 | } elsif ($token eq "<") { |
| 921 | push @phrase, (splice @address), (splice @buffer); |
| 922 | } elsif ($token eq ">") { |
| 923 | push @address, (splice @buffer); |
| 924 | } elsif ($token eq "@") { |
| 925 | push @address, (splice @buffer), "@"; |
| 926 | } elsif ($token eq ".") { |
| 927 | push @address, (splice @buffer), "."; |
| 928 | } else { |
| 929 | push @buffer, $token; |
| 930 | } |
| 931 | } |
| 932 | |
| 933 | return @addr_list; |
| 934 | } |
Petr Baudis | c7a30e5 | 2006-07-03 22:48:01 +0200 | [diff] [blame] | 935 | |
Petr Baudis | 24c4b71 | 2006-06-25 03:54:26 +0200 | [diff] [blame] | 936 | =item hash_object ( TYPE, FILENAME ) |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 937 | |
Lea Wiemann | 58c8dd2 | 2008-06-01 22:26:25 +0200 | [diff] [blame] | 938 | Compute the SHA1 object id of the given C<FILENAME> considering it is |
| 939 | of the C<TYPE> object type (C<blob>, C<commit>, C<tree>). |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 940 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 941 | The method can be called without any instance or on a specified Git repository, |
| 942 | it makes zero difference. |
| 943 | |
| 944 | The function returns the SHA1 hash. |
| 945 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 946 | =cut |
| 947 | |
Petr Baudis | 18b0fc1 | 2006-09-23 20:20:47 +0200 | [diff] [blame] | 948 | # TODO: Support for passing FILEHANDLE instead of FILENAME |
Petr Baudis | e6634ac | 2006-07-02 01:38:56 +0200 | [diff] [blame] | 949 | sub hash_object { |
| 950 | my ($self, $type, $file) = _maybe_self(@_); |
Petr Baudis | 18b0fc1 | 2006-09-23 20:20:47 +0200 | [diff] [blame] | 951 | command_oneline('hash-object', '-t', $type, $file); |
Petr Baudis | e6634ac | 2006-07-02 01:38:56 +0200 | [diff] [blame] | 952 | } |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 953 | |
| 954 | |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 955 | =item hash_and_insert_object ( FILENAME ) |
| 956 | |
| 957 | Compute the SHA1 object id of the given C<FILENAME> and add the object to the |
| 958 | object database. |
| 959 | |
| 960 | The function returns the SHA1 hash. |
| 961 | |
| 962 | =cut |
| 963 | |
| 964 | # TODO: Support for passing FILEHANDLE instead of FILENAME |
| 965 | sub hash_and_insert_object { |
| 966 | my ($self, $filename) = @_; |
| 967 | |
| 968 | carp "Bad filename \"$filename\"" if $filename =~ /[\r\n]/; |
| 969 | |
| 970 | $self->_open_hash_and_insert_object_if_needed(); |
| 971 | my ($in, $out) = ($self->{hash_object_in}, $self->{hash_object_out}); |
| 972 | |
| 973 | unless (print $out $filename, "\n") { |
| 974 | $self->_close_hash_and_insert_object(); |
| 975 | throw Error::Simple("out pipe went bad"); |
| 976 | } |
| 977 | |
| 978 | chomp(my $hash = <$in>); |
| 979 | unless (defined($hash)) { |
| 980 | $self->_close_hash_and_insert_object(); |
| 981 | throw Error::Simple("in pipe went bad"); |
| 982 | } |
| 983 | |
| 984 | return $hash; |
| 985 | } |
| 986 | |
| 987 | sub _open_hash_and_insert_object_if_needed { |
| 988 | my ($self) = @_; |
| 989 | |
| 990 | return if defined($self->{hash_object_pid}); |
| 991 | |
| 992 | ($self->{hash_object_pid}, $self->{hash_object_in}, |
| 993 | $self->{hash_object_out}, $self->{hash_object_ctx}) = |
Masatake Osanai | 48d9e6a | 2011-02-15 07:13:04 +0900 | [diff] [blame] | 994 | $self->command_bidi_pipe(qw(hash-object -w --stdin-paths --no-filters)); |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 995 | } |
| 996 | |
| 997 | sub _close_hash_and_insert_object { |
| 998 | my ($self) = @_; |
| 999 | |
| 1000 | return unless defined($self->{hash_object_pid}); |
| 1001 | |
| 1002 | my @vars = map { 'hash_object_' . $_ } qw(pid in out ctx); |
| 1003 | |
Abhijit Menon-Sen | 452d36b | 2008-08-04 10:32:47 +0530 | [diff] [blame] | 1004 | command_close_bidi_pipe(@$self{@vars}); |
| 1005 | delete @$self{@vars}; |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 1006 | } |
| 1007 | |
| 1008 | =item cat_blob ( SHA1, FILEHANDLE ) |
| 1009 | |
| 1010 | Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and |
| 1011 | returns the number of bytes printed. |
| 1012 | |
| 1013 | =cut |
| 1014 | |
| 1015 | sub cat_blob { |
| 1016 | my ($self, $sha1, $fh) = @_; |
| 1017 | |
| 1018 | $self->_open_cat_blob_if_needed(); |
| 1019 | my ($in, $out) = ($self->{cat_blob_in}, $self->{cat_blob_out}); |
| 1020 | |
| 1021 | unless (print $out $sha1, "\n") { |
| 1022 | $self->_close_cat_blob(); |
| 1023 | throw Error::Simple("out pipe went bad"); |
| 1024 | } |
| 1025 | |
| 1026 | my $description = <$in>; |
| 1027 | if ($description =~ / missing$/) { |
| 1028 | carp "$sha1 doesn't exist in the repository"; |
Junio C Hamano | d683a0e | 2008-05-27 23:33:22 -0700 | [diff] [blame] | 1029 | return -1; |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 1030 | } |
| 1031 | |
| 1032 | if ($description !~ /^[0-9a-fA-F]{40} \S+ (\d+)$/) { |
| 1033 | carp "Unexpected result returned from git cat-file"; |
Junio C Hamano | d683a0e | 2008-05-27 23:33:22 -0700 | [diff] [blame] | 1034 | return -1; |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 1035 | } |
| 1036 | |
| 1037 | my $size = $1; |
| 1038 | |
| 1039 | my $blob; |
Joshua Clayton | 712c6ad | 2013-02-22 13:01:18 -0800 | [diff] [blame] | 1040 | my $bytesLeft = $size; |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 1041 | |
| 1042 | while (1) { |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 1043 | last unless $bytesLeft; |
| 1044 | |
| 1045 | my $bytesToRead = $bytesLeft < 1024 ? $bytesLeft : 1024; |
Joshua Clayton | 712c6ad | 2013-02-22 13:01:18 -0800 | [diff] [blame] | 1046 | my $read = read($in, $blob, $bytesToRead); |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 1047 | unless (defined($read)) { |
| 1048 | $self->_close_cat_blob(); |
| 1049 | throw Error::Simple("in pipe went bad"); |
| 1050 | } |
Joshua Clayton | 712c6ad | 2013-02-22 13:01:18 -0800 | [diff] [blame] | 1051 | unless (print $fh $blob) { |
| 1052 | $self->_close_cat_blob(); |
| 1053 | throw Error::Simple("couldn't write to passed in filehandle"); |
| 1054 | } |
| 1055 | $bytesLeft -= $read; |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 1056 | } |
| 1057 | |
| 1058 | # Skip past the trailing newline. |
| 1059 | my $newline; |
| 1060 | my $read = read($in, $newline, 1); |
| 1061 | unless (defined($read)) { |
| 1062 | $self->_close_cat_blob(); |
| 1063 | throw Error::Simple("in pipe went bad"); |
| 1064 | } |
| 1065 | unless ($read == 1 && $newline eq "\n") { |
| 1066 | $self->_close_cat_blob(); |
| 1067 | throw Error::Simple("didn't find newline after blob"); |
| 1068 | } |
| 1069 | |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 1070 | return $size; |
| 1071 | } |
| 1072 | |
| 1073 | sub _open_cat_blob_if_needed { |
| 1074 | my ($self) = @_; |
| 1075 | |
| 1076 | return if defined($self->{cat_blob_pid}); |
| 1077 | |
| 1078 | ($self->{cat_blob_pid}, $self->{cat_blob_in}, |
| 1079 | $self->{cat_blob_out}, $self->{cat_blob_ctx}) = |
Masatake Osanai | 48d9e6a | 2011-02-15 07:13:04 +0900 | [diff] [blame] | 1080 | $self->command_bidi_pipe(qw(cat-file --batch)); |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 1081 | } |
| 1082 | |
| 1083 | sub _close_cat_blob { |
| 1084 | my ($self) = @_; |
| 1085 | |
| 1086 | return unless defined($self->{cat_blob_pid}); |
| 1087 | |
| 1088 | my @vars = map { 'cat_blob_' . $_ } qw(pid in out ctx); |
| 1089 | |
Abhijit Menon-Sen | 452d36b | 2008-08-04 10:32:47 +0530 | [diff] [blame] | 1090 | command_close_bidi_pipe(@$self{@vars}); |
| 1091 | delete @$self{@vars}; |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 1092 | } |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 1093 | |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1094 | |
Michal Nazarewicz | 52dce6d | 2013-02-12 15:02:32 +0100 | [diff] [blame] | 1095 | =item credential_read( FILEHANDLE ) |
| 1096 | |
| 1097 | Reads credential key-value pairs from C<FILEHANDLE>. Reading stops at EOF or |
| 1098 | when an empty line is encountered. Each line must be of the form C<key=value> |
| 1099 | with a non-empty key. Function returns hash with all read values. Any white |
| 1100 | space (other than new-line character) is preserved. |
| 1101 | |
| 1102 | =cut |
| 1103 | |
| 1104 | sub credential_read { |
| 1105 | my ($self, $reader) = _maybe_self(@_); |
| 1106 | my %credential; |
| 1107 | while (<$reader>) { |
| 1108 | chomp; |
| 1109 | if ($_ eq '') { |
| 1110 | last; |
| 1111 | } elsif (!/^([^=]+)=(.*)$/) { |
| 1112 | throw Error::Simple("unable to parse git credential data:\n$_"); |
| 1113 | } |
| 1114 | $credential{$1} = $2; |
| 1115 | } |
| 1116 | return %credential; |
| 1117 | } |
| 1118 | |
| 1119 | =item credential_write( FILEHANDLE, CREDENTIAL_HASHREF ) |
| 1120 | |
| 1121 | Writes credential key-value pairs from hash referenced by |
| 1122 | C<CREDENTIAL_HASHREF> to C<FILEHANDLE>. Keys and values cannot contain |
| 1123 | new-lines or NUL bytes characters, and key cannot contain equal signs nor be |
| 1124 | empty (if they do Error::Simple is thrown). Any white space is preserved. If |
| 1125 | value for a key is C<undef>, it will be skipped. |
| 1126 | |
| 1127 | If C<'url'> key exists it will be written first. (All the other key-value |
| 1128 | pairs are written in sorted order but you should not depend on that). Once |
| 1129 | all lines are written, an empty line is printed. |
| 1130 | |
| 1131 | =cut |
| 1132 | |
| 1133 | sub credential_write { |
| 1134 | my ($self, $writer, $credential) = _maybe_self(@_); |
| 1135 | my ($key, $value); |
| 1136 | |
| 1137 | # Check if $credential is valid prior to writing anything |
| 1138 | while (($key, $value) = each %$credential) { |
| 1139 | if (!defined $key || !length $key) { |
| 1140 | throw Error::Simple("credential key empty or undefined"); |
| 1141 | } elsif ($key =~ /[=\n\0]/) { |
| 1142 | throw Error::Simple("credential key contains invalid characters: $key"); |
| 1143 | } elsif (defined $value && $value =~ /[\n\0]/) { |
| 1144 | throw Error::Simple("credential value for key=$key contains invalid characters: $value"); |
| 1145 | } |
| 1146 | } |
| 1147 | |
| 1148 | for $key (sort { |
| 1149 | # url overwrites other fields, so it must come first |
| 1150 | return -1 if $a eq 'url'; |
| 1151 | return 1 if $b eq 'url'; |
| 1152 | return $a cmp $b; |
| 1153 | } keys %$credential) { |
| 1154 | if (defined $credential->{$key}) { |
| 1155 | print $writer $key, '=', $credential->{$key}, "\n"; |
| 1156 | } |
| 1157 | } |
| 1158 | print $writer "\n"; |
| 1159 | } |
| 1160 | |
| 1161 | sub _credential_run { |
| 1162 | my ($self, $credential, $op) = _maybe_self(@_); |
| 1163 | my ($pid, $reader, $writer, $ctx) = command_bidi_pipe('credential', $op); |
| 1164 | |
| 1165 | credential_write $writer, $credential; |
| 1166 | close $writer; |
| 1167 | |
| 1168 | if ($op eq "fill") { |
| 1169 | %$credential = credential_read $reader; |
| 1170 | } |
| 1171 | if (<$reader>) { |
| 1172 | throw Error::Simple("unexpected output from git credential $op response:\n$_\n"); |
| 1173 | } |
| 1174 | |
| 1175 | command_close_bidi_pipe($pid, $reader, undef, $ctx); |
| 1176 | } |
| 1177 | |
| 1178 | =item credential( CREDENTIAL_HASHREF [, OPERATION ] ) |
| 1179 | |
| 1180 | =item credential( CREDENTIAL_HASHREF, CODE ) |
| 1181 | |
| 1182 | Executes C<git credential> for a given set of credentials and specified |
| 1183 | operation. In both forms C<CREDENTIAL_HASHREF> needs to be a reference to |
| 1184 | a hash which stores credentials. Under certain conditions the hash can |
| 1185 | change. |
| 1186 | |
| 1187 | In the first form, C<OPERATION> can be C<'fill'>, C<'approve'> or C<'reject'>, |
| 1188 | and function will execute corresponding C<git credential> sub-command. If |
| 1189 | it's omitted C<'fill'> is assumed. In case of C<'fill'> the values stored in |
| 1190 | C<CREDENTIAL_HASHREF> will be changed to the ones returned by the C<git |
| 1191 | credential fill> command. The usual usage would look something like: |
| 1192 | |
| 1193 | my %cred = ( |
| 1194 | 'protocol' => 'https', |
| 1195 | 'host' => 'example.com', |
| 1196 | 'username' => 'bob' |
| 1197 | ); |
| 1198 | Git::credential \%cred; |
| 1199 | if (try_to_authenticate($cred{'username'}, $cred{'password'})) { |
| 1200 | Git::credential \%cred, 'approve'; |
| 1201 | ... do more stuff ... |
| 1202 | } else { |
| 1203 | Git::credential \%cred, 'reject'; |
| 1204 | } |
| 1205 | |
| 1206 | In the second form, C<CODE> needs to be a reference to a subroutine. The |
| 1207 | function will execute C<git credential fill> to fill the provided credential |
| 1208 | hash, then call C<CODE> with C<CREDENTIAL_HASHREF> as the sole argument. If |
| 1209 | C<CODE>'s return value is defined, the function will execute C<git credential |
| 1210 | approve> (if return value yields true) or C<git credential reject> (if return |
| 1211 | value is false). If the return value is undef, nothing at all is executed; |
| 1212 | this is useful, for example, if the credential could neither be verified nor |
| 1213 | rejected due to an unrelated network error. The return value is the same as |
| 1214 | what C<CODE> returns. With this form, the usage might look as follows: |
| 1215 | |
| 1216 | if (Git::credential { |
| 1217 | 'protocol' => 'https', |
| 1218 | 'host' => 'example.com', |
| 1219 | 'username' => 'bob' |
| 1220 | }, sub { |
| 1221 | my $cred = shift; |
| 1222 | return !!try_to_authenticate($cred->{'username'}, |
| 1223 | $cred->{'password'}); |
| 1224 | }) { |
| 1225 | ... do more stuff ... |
| 1226 | } |
| 1227 | |
| 1228 | =cut |
| 1229 | |
| 1230 | sub credential { |
| 1231 | my ($self, $credential, $op_or_code) = (_maybe_self(@_), 'fill'); |
| 1232 | |
| 1233 | if ('CODE' eq ref $op_or_code) { |
| 1234 | _credential_run $credential, 'fill'; |
| 1235 | my $ret = $op_or_code->($credential); |
| 1236 | if (defined $ret) { |
| 1237 | _credential_run $credential, $ret ? 'approve' : 'reject'; |
| 1238 | } |
| 1239 | return $ret; |
| 1240 | } else { |
| 1241 | _credential_run $credential, $op_or_code; |
| 1242 | } |
| 1243 | } |
| 1244 | |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1245 | { # %TEMP_* Lexical Context |
| 1246 | |
Marcus Griep | 836ff95 | 2008-09-08 12:53:01 -0400 | [diff] [blame] | 1247 | my (%TEMP_FILEMAP, %TEMP_FILES); |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1248 | |
| 1249 | =item temp_acquire ( NAME ) |
| 1250 | |
Stefano Lattarini | 41ccfdd | 2013-04-12 00:36:10 +0200 | [diff] [blame] | 1251 | Attempts to retrieve the temporary file mapped to the string C<NAME>. If an |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1252 | associated temp file has not been created this session or was closed, it is |
| 1253 | created, cached, and set for autoflush and binmode. |
| 1254 | |
| 1255 | Internally locks the file mapped to C<NAME>. This lock must be released with |
| 1256 | C<temp_release()> when the temp file is no longer needed. Subsequent attempts |
| 1257 | to retrieve temporary files mapped to the same C<NAME> while still locked will |
| 1258 | cause an error. This locking mechanism provides a weak guarantee and is not |
| 1259 | threadsafe. It does provide some error checking to help prevent temp file refs |
| 1260 | writing over one another. |
| 1261 | |
| 1262 | In general, the L<File::Handle> returned should not be closed by consumers as |
| 1263 | it defeats the purpose of this caching mechanism. If you need to close the temp |
| 1264 | file handle, then you should use L<File::Temp> or another temp file faculty |
| 1265 | directly. If a handle is closed and then requested again, then a warning will |
| 1266 | issue. |
| 1267 | |
| 1268 | =cut |
| 1269 | |
| 1270 | sub temp_acquire { |
Marten Svanfeldt (dev) | bcdd1b4 | 2008-11-13 20:04:09 +0800 | [diff] [blame] | 1271 | my $temp_fd = _temp_cache(@_); |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1272 | |
Marcus Griep | 836ff95 | 2008-09-08 12:53:01 -0400 | [diff] [blame] | 1273 | $TEMP_FILES{$temp_fd}{locked} = 1; |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1274 | $temp_fd; |
| 1275 | } |
| 1276 | |
Kyle J. McKay | 4e63dcc | 2013-07-06 21:20:48 -0700 | [diff] [blame] | 1277 | =item temp_is_locked ( NAME ) |
| 1278 | |
| 1279 | Returns true if the internal lock created by a previous C<temp_acquire()> |
| 1280 | call with C<NAME> is still in effect. |
| 1281 | |
| 1282 | When temp_acquire is called on a C<NAME>, it internally locks the temporary |
| 1283 | file mapped to C<NAME>. That lock will not be released until C<temp_release()> |
| 1284 | is called with either the original C<NAME> or the L<File::Handle> that was |
| 1285 | returned from the original call to temp_acquire. |
| 1286 | |
| 1287 | Subsequent attempts to call C<temp_acquire()> with the same C<NAME> will fail |
| 1288 | unless there has been an intervening C<temp_release()> call for that C<NAME> |
| 1289 | (or its corresponding L<File::Handle> that was returned by the original |
| 1290 | C<temp_acquire()> call). |
| 1291 | |
| 1292 | If true is returned by C<temp_is_locked()> for a C<NAME>, an attempt to |
| 1293 | C<temp_acquire()> the same C<NAME> will cause an error unless |
| 1294 | C<temp_release> is first called on that C<NAME> (or its corresponding |
| 1295 | L<File::Handle> that was returned by the original C<temp_acquire()> call). |
| 1296 | |
| 1297 | =cut |
| 1298 | |
| 1299 | sub temp_is_locked { |
| 1300 | my ($self, $name) = _maybe_self(@_); |
| 1301 | my $temp_fd = \$TEMP_FILEMAP{$name}; |
| 1302 | |
| 1303 | defined $$temp_fd && $$temp_fd->opened && $TEMP_FILES{$$temp_fd}{locked}; |
| 1304 | } |
| 1305 | |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1306 | =item temp_release ( NAME ) |
| 1307 | |
| 1308 | =item temp_release ( FILEHANDLE ) |
| 1309 | |
| 1310 | Releases a lock acquired through C<temp_acquire()>. Can be called either with |
| 1311 | the C<NAME> mapping used when acquiring the temp file or with the C<FILEHANDLE> |
| 1312 | referencing a locked temp file. |
| 1313 | |
| 1314 | Warns if an attempt is made to release a file that is not locked. |
| 1315 | |
| 1316 | The temp file will be truncated before being released. This can help to reduce |
| 1317 | disk I/O where the system is smart enough to detect the truncation while data |
| 1318 | is in the output buffers. Beware that after the temp file is released and |
| 1319 | truncated, any operations on that file may fail miserably until it is |
| 1320 | re-acquired. All contents are lost between each release and acquire mapped to |
| 1321 | the same string. |
| 1322 | |
| 1323 | =cut |
| 1324 | |
| 1325 | sub temp_release { |
| 1326 | my ($self, $temp_fd, $trunc) = _maybe_self(@_); |
| 1327 | |
Marcus Griep | 836ff95 | 2008-09-08 12:53:01 -0400 | [diff] [blame] | 1328 | if (exists $TEMP_FILEMAP{$temp_fd}) { |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1329 | $temp_fd = $TEMP_FILES{$temp_fd}; |
| 1330 | } |
Marcus Griep | 836ff95 | 2008-09-08 12:53:01 -0400 | [diff] [blame] | 1331 | unless ($TEMP_FILES{$temp_fd}{locked}) { |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1332 | carp "Attempt to release temp file '", |
| 1333 | $temp_fd, "' that has not been locked"; |
| 1334 | } |
| 1335 | temp_reset($temp_fd) if $trunc and $temp_fd->opened; |
| 1336 | |
Marcus Griep | 836ff95 | 2008-09-08 12:53:01 -0400 | [diff] [blame] | 1337 | $TEMP_FILES{$temp_fd}{locked} = 0; |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1338 | undef; |
| 1339 | } |
| 1340 | |
| 1341 | sub _temp_cache { |
Marten Svanfeldt (dev) | bcdd1b4 | 2008-11-13 20:04:09 +0800 | [diff] [blame] | 1342 | my ($self, $name) = _maybe_self(@_); |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1343 | |
Marcus Griep | c14c8ce | 2008-08-15 15:53:59 -0400 | [diff] [blame] | 1344 | _verify_require(); |
| 1345 | |
Marcus Griep | 836ff95 | 2008-09-08 12:53:01 -0400 | [diff] [blame] | 1346 | my $temp_fd = \$TEMP_FILEMAP{$name}; |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1347 | if (defined $$temp_fd and $$temp_fd->opened) { |
Kyle J. McKay | 9c08107 | 2013-07-18 17:16:16 -0700 | [diff] [blame] | 1348 | if ($TEMP_FILES{$$temp_fd}{locked}) { |
Jay Soffian | 8faea4f | 2009-01-13 17:41:35 -0500 | [diff] [blame] | 1349 | throw Error::Simple("Temp file with moniker '" . |
| 1350 | $name . "' already in use"); |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1351 | } |
| 1352 | } else { |
| 1353 | if (defined $$temp_fd) { |
| 1354 | # then we're here because of a closed handle. |
| 1355 | carp "Temp file '", $name, |
| 1356 | "' was closed. Opening replacement."; |
| 1357 | } |
Marcus Griep | 836ff95 | 2008-09-08 12:53:01 -0400 | [diff] [blame] | 1358 | my $fname; |
Marten Svanfeldt (dev) | bcdd1b4 | 2008-11-13 20:04:09 +0800 | [diff] [blame] | 1359 | |
| 1360 | my $tmpdir; |
| 1361 | if (defined $self) { |
| 1362 | $tmpdir = $self->repo_path(); |
| 1363 | } |
| 1364 | |
Eric Wong | 822aaf0 | 2014-10-29 19:31:55 +0000 | [diff] [blame] | 1365 | my $n = $name; |
| 1366 | $n =~ s/\W/_/g; # no strange chars |
| 1367 | |
H. Merijn Brand | eafc2dd | 2013-04-29 01:09:57 -0700 | [diff] [blame] | 1368 | ($$temp_fd, $fname) = File::Temp::tempfile( |
Eric Wong | 822aaf0 | 2014-10-29 19:31:55 +0000 | [diff] [blame] | 1369 | "Git_${n}_XXXXXX", UNLINK => 1, DIR => $tmpdir, |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1370 | ) or throw Error::Simple("couldn't open new temp file"); |
Marten Svanfeldt (dev) | bcdd1b4 | 2008-11-13 20:04:09 +0800 | [diff] [blame] | 1371 | |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1372 | $$temp_fd->autoflush; |
| 1373 | binmode $$temp_fd; |
Marcus Griep | 836ff95 | 2008-09-08 12:53:01 -0400 | [diff] [blame] | 1374 | $TEMP_FILES{$$temp_fd}{fname} = $fname; |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1375 | } |
| 1376 | $$temp_fd; |
| 1377 | } |
| 1378 | |
Marcus Griep | c14c8ce | 2008-08-15 15:53:59 -0400 | [diff] [blame] | 1379 | sub _verify_require { |
| 1380 | eval { require File::Temp; require File::Spec; }; |
| 1381 | $@ and throw Error::Simple($@); |
| 1382 | } |
| 1383 | |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1384 | =item temp_reset ( FILEHANDLE ) |
| 1385 | |
| 1386 | Truncates and resets the position of the C<FILEHANDLE>. |
| 1387 | |
| 1388 | =cut |
| 1389 | |
| 1390 | sub temp_reset { |
| 1391 | my ($self, $temp_fd) = _maybe_self(@_); |
| 1392 | |
| 1393 | truncate $temp_fd, 0 |
| 1394 | or throw Error::Simple("couldn't truncate file"); |
| 1395 | sysseek($temp_fd, 0, SEEK_SET) and seek($temp_fd, 0, SEEK_SET) |
| 1396 | or throw Error::Simple("couldn't seek to beginning of file"); |
| 1397 | sysseek($temp_fd, 0, SEEK_CUR) == 0 and tell($temp_fd) == 0 |
| 1398 | or throw Error::Simple("expected file position to be reset"); |
| 1399 | } |
| 1400 | |
Marcus Griep | 836ff95 | 2008-09-08 12:53:01 -0400 | [diff] [blame] | 1401 | =item temp_path ( NAME ) |
| 1402 | |
| 1403 | =item temp_path ( FILEHANDLE ) |
| 1404 | |
| 1405 | Returns the filename associated with the given tempfile. |
| 1406 | |
| 1407 | =cut |
| 1408 | |
| 1409 | sub temp_path { |
| 1410 | my ($self, $temp_fd) = _maybe_self(@_); |
| 1411 | |
| 1412 | if (exists $TEMP_FILEMAP{$temp_fd}) { |
| 1413 | $temp_fd = $TEMP_FILEMAP{$temp_fd}; |
| 1414 | } |
| 1415 | $TEMP_FILES{$temp_fd}{fname}; |
| 1416 | } |
| 1417 | |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1418 | sub END { |
Marcus Griep | 836ff95 | 2008-09-08 12:53:01 -0400 | [diff] [blame] | 1419 | unlink values %TEMP_FILEMAP if %TEMP_FILEMAP; |
Marcus Griep | e41352b | 2008-08-12 12:00:18 -0400 | [diff] [blame] | 1420 | } |
| 1421 | |
| 1422 | } # %TEMP_* Lexical Context |
| 1423 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1424 | =back |
| 1425 | |
Petr Baudis | 97b16c0 | 2006-06-24 04:34:42 +0200 | [diff] [blame] | 1426 | =head1 ERROR HANDLING |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1427 | |
Petr Baudis | 97b16c0 | 2006-06-24 04:34:42 +0200 | [diff] [blame] | 1428 | All functions are supposed to throw Perl exceptions in case of errors. |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 1429 | See the L<Error> module on how to catch those. Most exceptions are mere |
| 1430 | L<Error::Simple> instances. |
| 1431 | |
| 1432 | However, the C<command()>, C<command_oneline()> and C<command_noisy()> |
| 1433 | functions suite can throw C<Git::Error::Command> exceptions as well: those are |
| 1434 | thrown when the external command returns an error code and contain the error |
| 1435 | code as well as access to the captured command's output. The exception class |
| 1436 | provides the usual C<stringify> and C<value> (command's exit code) methods and |
| 1437 | in addition also a C<cmd_output> method that returns either an array or a |
| 1438 | string with the captured command output (depending on the original function |
| 1439 | call context; C<command_noisy()> returns C<undef>) and $<cmdline> which |
| 1440 | returns the command and its arguments (but without proper quoting). |
| 1441 | |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 1442 | Note that the C<command_*_pipe()> functions cannot throw this exception since |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 1443 | it has no idea whether the command failed or not. You will only find out |
| 1444 | at the time you C<close> the pipe; if you want to have that automated, |
| 1445 | use C<command_close_pipe()>, which can throw the exception. |
| 1446 | |
| 1447 | =cut |
| 1448 | |
| 1449 | { |
| 1450 | package Git::Error::Command; |
| 1451 | |
| 1452 | @Git::Error::Command::ISA = qw(Error); |
| 1453 | |
| 1454 | sub new { |
| 1455 | my $self = shift; |
| 1456 | my $cmdline = '' . shift; |
| 1457 | my $value = 0 + shift; |
| 1458 | my $outputref = shift; |
| 1459 | my(@args) = (); |
| 1460 | |
| 1461 | local $Error::Depth = $Error::Depth + 1; |
| 1462 | |
| 1463 | push(@args, '-cmdline', $cmdline); |
| 1464 | push(@args, '-value', $value); |
| 1465 | push(@args, '-outputref', $outputref); |
| 1466 | |
| 1467 | $self->SUPER::new(-text => 'command returned error', @args); |
| 1468 | } |
| 1469 | |
| 1470 | sub stringify { |
| 1471 | my $self = shift; |
| 1472 | my $text = $self->SUPER::stringify; |
| 1473 | $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n"; |
| 1474 | } |
| 1475 | |
| 1476 | sub cmdline { |
| 1477 | my $self = shift; |
| 1478 | $self->{'-cmdline'}; |
| 1479 | } |
| 1480 | |
| 1481 | sub cmd_output { |
| 1482 | my $self = shift; |
| 1483 | my $ref = $self->{'-outputref'}; |
| 1484 | defined $ref or undef; |
| 1485 | if (ref $ref eq 'ARRAY') { |
| 1486 | return @$ref; |
| 1487 | } else { # SCALAR |
| 1488 | return $$ref; |
| 1489 | } |
| 1490 | } |
| 1491 | } |
| 1492 | |
| 1493 | =over 4 |
| 1494 | |
| 1495 | =item git_cmd_try { CODE } ERRMSG |
| 1496 | |
| 1497 | This magical statement will automatically catch any C<Git::Error::Command> |
| 1498 | exceptions thrown by C<CODE> and make your program die with C<ERRMSG> |
| 1499 | on its lips; the message will have %s substituted for the command line |
| 1500 | and %d for the exit status. This statement is useful mostly for producing |
| 1501 | more user-friendly error messages. |
| 1502 | |
| 1503 | In case of no exception caught the statement returns C<CODE>'s return value. |
| 1504 | |
| 1505 | Note that this is the only auto-exported function. |
| 1506 | |
| 1507 | =cut |
| 1508 | |
| 1509 | sub git_cmd_try(&$) { |
| 1510 | my ($code, $errmsg) = @_; |
| 1511 | my @result; |
| 1512 | my $err; |
| 1513 | my $array = wantarray; |
| 1514 | try { |
| 1515 | if ($array) { |
| 1516 | @result = &$code; |
| 1517 | } else { |
| 1518 | $result[0] = &$code; |
| 1519 | } |
| 1520 | } catch Git::Error::Command with { |
| 1521 | my $E = shift; |
| 1522 | $err = $errmsg; |
| 1523 | $err =~ s/\%s/$E->cmdline()/ge; |
| 1524 | $err =~ s/\%d/$E->value()/ge; |
| 1525 | # We can't croak here since Error.pm would mangle |
| 1526 | # that to Error::Simple. |
| 1527 | }; |
| 1528 | $err and croak $err; |
| 1529 | return $array ? @result : $result[0]; |
| 1530 | } |
| 1531 | |
| 1532 | |
| 1533 | =back |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1534 | |
| 1535 | =head1 COPYRIGHT |
| 1536 | |
| 1537 | Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>. |
| 1538 | |
| 1539 | This module is free software; it may be used, copied, modified |
| 1540 | and distributed under the terms of the GNU General Public Licence, |
| 1541 | either version 2, or (at your option) any later version. |
| 1542 | |
| 1543 | =cut |
| 1544 | |
| 1545 | |
| 1546 | # Take raw method argument list and return ($obj, @args) in case |
| 1547 | # the method was called upon an instance and (undef, @args) if |
| 1548 | # it was called directly. |
| 1549 | sub _maybe_self { |
Christian Jaeger | d8b24b9 | 2008-10-18 20:25:12 +0200 | [diff] [blame] | 1550 | UNIVERSAL::isa($_[0], 'Git') ? @_ : (undef, @_); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1551 | } |
| 1552 | |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 1553 | # Check if the command id is something reasonable. |
| 1554 | sub _check_valid_cmd { |
| 1555 | my ($cmd) = @_; |
| 1556 | $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd"); |
| 1557 | } |
| 1558 | |
| 1559 | # Common backend for the pipe creators. |
| 1560 | sub _command_common_pipe { |
| 1561 | my $direction = shift; |
Petr Baudis | d43ba46 | 2006-06-24 04:34:49 +0200 | [diff] [blame] | 1562 | my ($self, @p) = _maybe_self(@_); |
| 1563 | my (%opts, $cmd, @args); |
| 1564 | if (ref $p[0]) { |
| 1565 | ($cmd, @args) = @{shift @p}; |
| 1566 | %opts = ref $p[0] ? %{$p[0]} : @p; |
| 1567 | } else { |
| 1568 | ($cmd, @args) = @p; |
| 1569 | } |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 1570 | _check_valid_cmd($cmd); |
| 1571 | |
Petr Baudis | a6065b5 | 2006-06-25 03:54:23 +0200 | [diff] [blame] | 1572 | my $fh; |
Alex Riesen | d3b1785 | 2007-01-22 17:14:56 +0100 | [diff] [blame] | 1573 | if ($^O eq 'MSWin32') { |
Petr Baudis | a6065b5 | 2006-06-25 03:54:23 +0200 | [diff] [blame] | 1574 | # ActiveState Perl |
| 1575 | #defined $opts{STDERR} and |
| 1576 | # warn 'ignoring STDERR option - running w/ ActiveState'; |
| 1577 | $direction eq '-|' or |
| 1578 | die 'input pipe for ActiveState not implemented'; |
Alex Riesen | bed118d | 2007-01-22 17:16:05 +0100 | [diff] [blame] | 1579 | # the strange construction with *ACPIPE is just to |
| 1580 | # explain the tie below that we want to bind to |
| 1581 | # a handle class, not scalar. It is not known if |
| 1582 | # it is something specific to ActiveState Perl or |
| 1583 | # just a Perl quirk. |
| 1584 | tie (*ACPIPE, 'Git::activestate_pipe', $cmd, @args); |
| 1585 | $fh = *ACPIPE; |
Petr Baudis | a6065b5 | 2006-06-25 03:54:23 +0200 | [diff] [blame] | 1586 | |
| 1587 | } else { |
| 1588 | my $pid = open($fh, $direction); |
| 1589 | if (not defined $pid) { |
| 1590 | throw Error::Simple("open failed: $!"); |
| 1591 | } elsif ($pid == 0) { |
Petr Baudis | a6065b5 | 2006-06-25 03:54:23 +0200 | [diff] [blame] | 1592 | if ($opts{STDERR}) { |
| 1593 | open (STDERR, '>&', $opts{STDERR}) |
| 1594 | or die "dup failed: $!"; |
Thomas Rast | bd4ca09 | 2013-04-04 22:41:41 +0200 | [diff] [blame] | 1595 | } elsif (defined $opts{STDERR}) { |
| 1596 | open (STDERR, '>', '/dev/null') |
| 1597 | or die "opening /dev/null failed: $!"; |
Petr Baudis | a6065b5 | 2006-06-25 03:54:23 +0200 | [diff] [blame] | 1598 | } |
| 1599 | _cmd_exec($self, $cmd, @args); |
Petr Baudis | d43ba46 | 2006-06-24 04:34:49 +0200 | [diff] [blame] | 1600 | } |
Petr Baudis | d79850e | 2006-06-24 04:34:47 +0200 | [diff] [blame] | 1601 | } |
| 1602 | return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh; |
| 1603 | } |
| 1604 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1605 | # When already in the subprocess, set up the appropriate state |
| 1606 | # for the given repository and execute the git command. |
| 1607 | sub _cmd_exec { |
| 1608 | my ($self, @args) = @_; |
Masatake Osanai | 48d9e6a | 2011-02-15 07:13:04 +0900 | [diff] [blame] | 1609 | _setup_git_cmd_env($self); |
| 1610 | _execv_git_cmd(@args); |
| 1611 | die qq[exec "@args" failed: $!]; |
| 1612 | } |
| 1613 | |
| 1614 | # set up the appropriate state for git command |
| 1615 | sub _setup_git_cmd_env { |
| 1616 | my $self = shift; |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1617 | if ($self) { |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 1618 | $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path(); |
Frank Lichtenheld | da159c7 | 2009-05-07 15:41:27 +0200 | [diff] [blame] | 1619 | $self->repo_path() and $self->wc_path() |
| 1620 | and $ENV{'GIT_WORK_TREE'} = $self->wc_path(); |
Petr Baudis | d5c7721 | 2006-06-24 04:34:51 +0200 | [diff] [blame] | 1621 | $self->wc_path() and chdir($self->wc_path()); |
| 1622 | $self->wc_subdir() and chdir($self->wc_subdir()); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1623 | } |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1624 | } |
| 1625 | |
Petr Baudis | 8062f81 | 2006-06-24 04:34:34 +0200 | [diff] [blame] | 1626 | # Execute the given Git command ($_[0]) with arguments ($_[1..]) |
| 1627 | # by searching for it at proper places. |
Petr Baudis | 18b0fc1 | 2006-09-23 20:20:47 +0200 | [diff] [blame] | 1628 | sub _execv_git_cmd { exec('git', @_); } |
Petr Baudis | 8062f81 | 2006-06-24 04:34:34 +0200 | [diff] [blame] | 1629 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1630 | # Close pipe to a subprocess. |
| 1631 | sub _cmd_close { |
Michal Nazarewicz | 1323dba | 2013-02-12 15:02:30 +0100 | [diff] [blame] | 1632 | my $ctx = shift @_; |
| 1633 | foreach my $fh (@_) { |
| 1634 | if (close $fh) { |
| 1635 | # nop |
| 1636 | } elsif ($!) { |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1637 | # It's just close, no point in fatalities |
| 1638 | carp "error closing pipe: $!"; |
| 1639 | } elsif ($? >> 8) { |
Petr Baudis | 8b9150e | 2006-06-24 04:34:44 +0200 | [diff] [blame] | 1640 | # The caller should pepper this. |
| 1641 | throw Git::Error::Command($ctx, $? >> 8); |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1642 | } |
| 1643 | # else we might e.g. closed a live stream; the command |
| 1644 | # dying of SIGPIPE would drive us here. |
| 1645 | } |
| 1646 | } |
| 1647 | |
| 1648 | |
Adam Roben | 7182530 | 2008-05-23 16:19:40 +0200 | [diff] [blame] | 1649 | sub DESTROY { |
| 1650 | my ($self) = @_; |
| 1651 | $self->_close_hash_and_insert_object(); |
| 1652 | $self->_close_cat_blob(); |
| 1653 | } |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1654 | |
| 1655 | |
Petr Baudis | a6065b5 | 2006-06-25 03:54:23 +0200 | [diff] [blame] | 1656 | # Pipe implementation for ActiveState Perl. |
| 1657 | |
| 1658 | package Git::activestate_pipe; |
| 1659 | use strict; |
| 1660 | |
| 1661 | sub TIEHANDLE { |
| 1662 | my ($class, @params) = @_; |
| 1663 | # FIXME: This is probably horrible idea and the thing will explode |
| 1664 | # at the moment you give it arguments that require some quoting, |
| 1665 | # but I have no ActiveState clue... --pasky |
Alex Riesen | d3b1785 | 2007-01-22 17:14:56 +0100 | [diff] [blame] | 1666 | # Let's just hope ActiveState Perl does at least the quoting |
| 1667 | # correctly. |
| 1668 | my @data = qx{git @params}; |
Petr Baudis | a6065b5 | 2006-06-25 03:54:23 +0200 | [diff] [blame] | 1669 | bless { i => 0, data => \@data }, $class; |
| 1670 | } |
| 1671 | |
| 1672 | sub READLINE { |
| 1673 | my $self = shift; |
| 1674 | if ($self->{i} >= scalar @{$self->{data}}) { |
| 1675 | return undef; |
| 1676 | } |
Alex Riesen | 2f5b398 | 2007-08-22 18:13:07 +0200 | [diff] [blame] | 1677 | my $i = $self->{i}; |
| 1678 | if (wantarray) { |
| 1679 | $self->{i} = $#{$self->{'data'}} + 1; |
| 1680 | return splice(@{$self->{'data'}}, $i); |
| 1681 | } |
| 1682 | $self->{i} = $i + 1; |
| 1683 | return $self->{'data'}->[ $i ]; |
Petr Baudis | a6065b5 | 2006-06-25 03:54:23 +0200 | [diff] [blame] | 1684 | } |
| 1685 | |
| 1686 | sub CLOSE { |
| 1687 | my $self = shift; |
| 1688 | delete $self->{data}; |
| 1689 | delete $self->{i}; |
| 1690 | } |
| 1691 | |
| 1692 | sub EOF { |
| 1693 | my $self = shift; |
| 1694 | return ($self->{i} >= scalar @{$self->{data}}); |
| 1695 | } |
| 1696 | |
| 1697 | |
Petr Baudis | b1edc53 | 2006-06-24 04:34:29 +0200 | [diff] [blame] | 1698 | 1; # Famous last words |