{"thread":{"id":"433","subject":"semi-useful git perl file","startedAt":"2005-05-02T05:33:49Z","lastAt":"2005-05-02T05:33:49Z","messageCount":1,"participants":["Joshua T. Corbin"],"isPatch":false,"patchVersion":null,"patchTotal":null},"messages":[{"id":"2356","messageId":"20050502053349.GF31862@node1.wunjo.org","threadId":"433","inReplyTo":null,"subject":"semi-useful git perl file","fromName":"Joshua T. Corbin","fromEmail":"jcorbin@node1.wunjo.org","sentAt":"2005-05-02T05:33:49Z","receivedAt":"2005-05-02T05:33:49Z","isPatch":false,"sender":{"key":"jcorbin@node1.wunjo.org","avatar":null},"body":"I've been playing around with driving git from perl land. The attached\nallows you to easily access git objects from perl as:\n\n\ttie %git, 'GIT::ObjectDB';\n\tprint Dumper( $git{ $commit_id } );\n\nLooks like:\n{\n\ttype    => 'commit',\n\tsha     => $commit_id,\n\ttree    => '0000000000000000000000000000000000000000',\n\tparents => [ ... ],\n\tmess    => \"\\nbla bla bla\\n\"\n}\n\nAnd corresponding for trees, tags, and blobs.\n\nIf you want to see use of this in action, you can pull my (incomplete)\ntranslation of cogito into perl from:\n\n\thttp://node1.wunjo.org/~jcorbin/yagf.git\n\n\tor\n\n\trsync://node1.wunjo.org/yagf.git\n\nJosh\n\n\npackage GIT;\nuse strict;\nour %cmd;\n\nsub cmdpath {\n\tmy $cmd = shift;\n\tunless ( defined $cmd{$cmd} ) {\n\t\tlocal $/ = \"\\n\";\n\t\tchomp( $cmd{$cmd} = `which $cmd` );\n\t\treturn undef if $cmd{$cmd} eq '';\n\t}\n\treturn $cmd{$cmd};\n}\n\nsub cmd {\n\tmy $cmd = shift;\n\tcmdpath( $cmd ) || die \"command '$cmd' not found\\n\";\n\tmy $r = system( $cmd{$cmd}, @_ );\n\tdie \"$cmd failed: \" . cmderrmsg( $cmd ) . \"\\n\"\n\t\tif $r != 0;\n\treturn 1;\n}\n\nsub cmdinout {\n\tmy $infh = shift;\n\tmy $cmd = shift;\n\tcmdpath( $cmd ) || die \"command '$cmd' not found\\n\";\n\tmy ( $r, $w );\n\tpipe( $r, $w ) || die \"Failed to pipe: $!\";\n\tmy $pid = fork();\n\tdie \"Failed to fork: $!\" unless defined $pid;\n\tif ( $pid ) {\n\t\tclose $w;\n\t\tmy $kid = waitpid( $pid, 0 );\n\t\tdie \"Hmm, auto reaping in place?\" if $kid == -1;\n\t\tdie \"$cmd failed: \" . cmderrmsg( $cmd ) . \"\\n\"\n\t\t\tif $? & 127 || $? >> 8 != 0;\n\t\tlocal $/;\n\t\tlocal $_ = <$r>;\n\t\tclose $r;\n\t\tif ( wantarray ) {\n\t\t\treturn split( \"\\n\", $_ );\n\t\t} else {\n\t\t\treturn $_;\n\t\t}\n\t} else {\n\t\tclose $r;\n\t\tclose STDOUT;\n\t\tclose STDIN;\n\t\topen STDIN, '<&', $infh || die \"Failed to rediret STDIN\";\n\t\topen STDOUT, '>&', $w || die \"Failed to redirect STDOUT\";\n\t\texec( $cmd{$cmd}, @_ );\n\t}\n}\n\nsub cmdout {\n\tmy $callback = shift if ref $_[0] eq 'CODE';\n\tmy $cmd = shift;\n\tcmdpath( $cmd ) || die \"command '$cmd' not found\\n\";\n\tmy ( $r, $w );\n\tpipe( $r, $w ) || die \"Failed to pipe: $!\";\n\tmy $pid = fork();\n\tdie \"Failed to fork: $!\" unless defined $pid;\n\tif ( $pid ) {\n\t\tclose $w;\n\t\tif ( defined $callback ) {\n\t\t\tlocal $_;\n\t\t\twhile ( <$r> ) {\n\t\t\t\tif ( &$callback() ) {\n\t\t\t\t\tkill 15, $pid;\n\t\t\t\t\tlast;\n\t\t\t\t}\n\t\t\t}\n\t\t\tclose $r;\n\t\t\twaitpid( $pid, 0 );\n\t\t\treturn 1;\n\t\t} else {\n\t\t\tmy $kid = waitpid( $pid, 0 );\n\t\t\tdie \"Hmm, auto reaping in place?\" if $kid == -1;\n\t\t\tdie \"$cmd failed: \" . cmderrmsg( $cmd ) . \"\\n\"\n\t\t\t\tif $? & 127 || $? >> 8 != 0;\n\t\t\tif ( wantarray ) {\n\t\t\t\tmy @r = <$r>;\n\t\t\t\tclose $r;\n\t\t\t\tchomp @r;\n\t\t\t\treturn @r;\n\t\t\t} else {\n\t\t\t\tlocal $/;\n\t\t\t\tmy $r = <$r>;\n\t\t\t\tclose $r;\n\t\t\t\treturn $r;\n\t\t\t}\n\t\t}\n\t} else {\n\t\tclose $r;\n\t\tclose STDOUT;\n\t\topen STDOUT, '>&', $w || die \"Failed to redirect STDOUT\";\n\t\texec( $cmd{$cmd}, @_ );\n\t}\n}\n\nsub cmderrmsg {\n\tmy $cmd = shift;\n\tmy $e;\n\tif ( $? == -1 ) {\n\t\t$e = \"failed to execute $cmd{$cmd}: $!\";\n\t} elsif ( $? & 127 ) {\n\t\t$e = sprintf( 'child died from signal %d', ( $? & 127 ) );\n\t\t$e .= ' (with coredump)' if $? & 128;\n\t} else {\n\t\t$e = sprintf( 'child exit value: %d', $? >> 8 );\n\t}\n\treturn $e;\n}\n\npackage GIT::ObjectDB;\nuse strict;\n# Cache this many commit/tree/tag objects, blobs are not cached because they are (possibly) huge.\nour $CacheMax = 20;\nour $MissingFatal;\nuse Carp qw( croak );\n\nsub TIEHASH {\n\tmy ( $class, $dir ) = @_;\n\t$dir ||= $ENV{SHA1_FILE_DIRECTORY} || '.git/objects';\n\t$ENV{SHA1_FILE_DIRECTORY} = $dir\n\t\tif $dir ne '.git/objects';\n\n\t( -d $dir ) || croak \"No such directory $dir\";\n\tbless my $self = {\n\t\tdir    => $dir,\n\t\ttypes  => {},\n\t\tcache  => {}, # What we're caching\n\t\tcachea => []  # The order we cached it in so\n\t} => $class;\n\treturn $self;\n}\n\nsub FETCH {\n\tmy ( $self, $key ) = @_;\n\tcroak \"Invalid sha1 key '$key'\" unless $key =~ /^[A-Za-z0-9]{40}$/;\n\treturn $self->{ cache }->{ $key }\n\t\tif defined $self->{ cache }->{ $key };\n\tmy $type = $self->objectType( $key );\n\tunless ( defined $type ) {\n\t\tdie \"no such object $key\" if $MissingFatal;\n\t\treturn undef;\n\t}\n\n\tif ( $type eq 'blob' ) {\n\t\treturn new GIT::ObjectDB::Blob( $key );\n\t} else {\n\t\tif ( $type eq 'tree' ) {\n\t\t\t$self->{ cache }->{ $key } =\n\t\t\t\tGIT::ObjectDB::Tree->new_fromkey( $key );\n\t\t} elsif ( $type eq 'commit' ) {\n\t\t\t$self->{ cache }->{ $key } =\n\t\t\t\tGIT::ObjectDB::Commit->new_fromkey( $key );\n\t\t} elsif ( $type eq 'tag' ) {\n\t\t\t$self->{ cache }->{ $key } =\n\t\t\t\tGIT::ObjectDB::Tag->new_fromkey( $key );\n\t\t} else {\n\t\t\tcroak \"Unrecognized object($key) type '$type'\";\n\t\t}\n\t\tpush @{ $self->{ cachea } }, $key;\n\t\twhile ( scalar @{ $self->{ cachea } } > $CacheMax ) {\n\t\t\tmy $k = shift @{ $self->{ cachea } };\n\t\t\tdelete $self->{ cache }->{ $k };\n\t\t}\n\t\treturn $self->{ cache }->{ $key };\n\t}\n}\n\nsub STORE {\n\tmy ( $self, $key, $value ) = @_;\n\tcroak \"Will not overwrite an object\"\n\t\tif defined $self->objectType( $key );\n\tif ( UNIVERSAL::isa( $value, 'GIT::ObjectDB::Commit' ) ) {\n\t\tmy $mess = $value->{ mess };\n\t\t$mess =~ /^\\s*$/s && croak \"Won't commit an empty message\";\n\t\tmy $fh;\n\t\topen $fh, '<', \\$mess;\n\t\tchomp( $value->{ sha } = GIT::cmdinout( $fh,\n\t\t\t'git-commit-tree', $value->{ tree },\n\t\t\tmap { ( '-p', $_ ) } @{ $value->{ parents } }\n\t\t) );\n\t\tclose $fh;\n\t} elsif ( UNIVERSAL::isa( $value, 'GIT::ObjectDB::Tag' ) ) {\n\t\tmy $type = $self->objectType( $value->{ object } ) ||\n\t\t\tcroak \"No such object $value->{object}\";\n\t\tcroak \"Tagging a tag?\" if $type eq 'tag';\n\t\tmy $tag =\n\t\t\t\"object $value->{object}\\n\" .\n\t\t\t\"type $type\\n\" .\n\t\t\t\"tag $value-{tag}\\n\" .\n\t\t\t$value->{ sig };\n\t\tmy $fh;\n\t\topen $fh, '<', \\$tag;\n\t\tchomp( $value->{ sha } = GIT::cmdinout( $fh, 'git-mktag' ) );\n\t\tclose $fh;\n\t} else {\n\t\tcroak \"Only support storing commits and tags\";\n\t}\n\tpush @{ $self->{ cachea } },\n\t\t$self->{ cache }->{ $value->{ sha } } = $value;\n\twhile ( scalar @{ $self->{ cachea } } > $CacheMax ) {\n\t\tmy $k = shift @{ $self->{ cachea } };\n\t\tdelete $self->{ cache }->{ $k };\n\t}\n}\n\nsub EXISTS {\n\tmy ( $self, $key ) = @_;\n\treturn defined( $self->objectType( $key ) ) ? 1 : 0;\n}\n\nsub FIRSTKEY {\n\tmy ( $self ) = @_;\n\tif ( defined $self->{ dh } ) {\n\t\tclosedir $self->{ dh };\n\t\tdelete $self->{ dh };\n\t}\n\t$self->{ i } = -1;\n\treturn $self->NEXTKEY;\n}\n\nsub NEXTKEY {\n\tmy ( $self ) = @_;\n\tmy $r;\n\tuntil ( defined $r ) {\n\t\tif ( defined $self->{ dh } ) {\n\t\t\t$r = readdir $self->{ dh };\n\t\t\tunless ( defined $r ) {\n\t\t\t\tclosedir $self->{ dh };\n\t\t\t\tdelete $self->{ dh };\n\t\t\t\tnext;\n\t\t\t}\n\t\t\t$r = undef if $r !~ /^[A-Za-z0-9]{38}$/;\n\t\t\t$r = sprintf( '%02x%s', $self->{ i }, $r ) if defined $r;\n\t\t} else {\n\t\t\t$self->{ i }++;\n\t\t\tlast if $self->{ i } > 0xff;\n\t\t\tmy $dh;\n\t\t\tmy $dir = sprintf( '%s/%02x', $self->{ dir }, $self->{ i } );\n\t\t\topendir $dh, $dir ||\n\t\t\t\tdie \"Failed to opendir $dir: $!\";\n\t\t\t$self->{ dh } = $dh;\n\t\t\tnext;\n\t\t}\n\t}\n\treturn $r;\n}\n\nsub SCALAR {\n\tmy ( $self ) = @_;\n\treturn $self->{ dir };\n}\n\nsub UNTIE {\n\tmy ( $self ) = @_;\n\tclosedir $self->{ dh } if defined $self->{ dh };\n}\n\nsub objectType {\n\tmy ( $self, $key ) = @_;\n\teval {\n\t\tchomp(\n\t\t\t( $self->{ types }->{ $key } ) =\n\t\t\t\tGIT::cmdout( 'git-cat-file', '-t', $key )\n\t\t) unless defined $self->{ types }->{ $key };\n\t};\n\treturn undef if $@;\n\treturn $self->{ types }->{ $key };\n}\n\npackage GIT::ObjectDB::Blob;\nuse strict;\n\nsub new {\n\tmy ( $class, $key ) = @_;\n\tbless {\n\t\ttype => 'blob',\n\t\tsha => $key\n\t} => $class;\n}\n\nsub contents {\n\tmy ( $self ) = @_;\n\treturn GIT::cmdout( 'git-cat-file', 'blob', $self->{ sha } );\n}\n\nsub write_to_filehandle {\n\tmy ( $self, $fh ) = @_;\n\tGIT::cmdout( sub {\n\t\tprint $fh $_;\n\t\treturn 0;\n\t}, 'git-cat-file', 'blob', $self->{ sha } );\n\treturn 1;\n}\n\npackage GIT::ObjectDB::Commit;\nuse strict;\nuse Carp qw( croak );\n\nsub new {\n\tmy $class   = shift;\n\tmy $mess    = shift          || croak \"Missing message\";\n\tmy $tree    = shift          || croak \"Missing tree\";\n\t$tree =~ /^[A-Za-z0-9]{40}$/ || croak \"Invalid tree id\";\n\tmy @parents = @_             or croak \"Missing parent(s)\";\n\tfor my $parent ( @parents ) {\n\t\t$parent =~ /^[A-Za-z0-9]{40}$/ || croak \"Invalid parent id '$parent'\";\n\t}\n\n\treturn bless {\n\t\ttype    => 'commit',\n\t\tparents => \\@parents,\n\t\ttree    => $tree,\n\t\tmess    => $mess\n\t} => $class;\n}\n\nsub new_fromkey {\n\tmy ( $class, $key ) = @_;\n\tbless my $self = {\n\t\ttype    => 'commit',\n\t\tsha     => $key,\n\t\tparents => [],\n\t\tmess    => ''\n\t} => $class;\n\n\tlocal $/ = \"\\n\";\n\tmy $no_more_parents;\n\tGIT::cmdout( sub {\n\t\tchomp;\n\t\tif ( ! defined $self->{ tree } && /^tree ([A-Za-z0-9]{40})$/ ) {\n\t\t\t$self->{ tree } = $1;\n\t\t} elsif ( ! $no_more_parents && /^parent ([A-Za-z0-9]{40})$/ ) {\n\t\t\tpush @{ $self->{ parents } }, $1;\n\t\t} else {\n\t\t\t$no_more_parents = 1;\n\t\t\tif ( ! defined $self->{ author } && /^author (.+) (\\d+ [-+]\\d{4})$/ ) {\n\t\t\t\t$self->{ author } = [ $1, $2 ];\n\t\t\t} elsif ( ! defined $self->{ committer } && /^committer (.+) (\\d+ [-+]\\d{4})$/ ) {\n\t\t\t\t$self->{ committer } = [ $1, $2 ];\n\t\t\t} else {\n\t\t\t\t$self->{ mess } .= \"$_\\n\";\n\t\t\t}\n\t\t}\n\t\treturn 0;\n\t}, 'git-cat-file', 'commit', $key );\n\n\treturn $self;\n}\n\npackage GIT::ObjectDB::Tree;\nuse strict;\n\nsub new_fromkey {\n\tmy ( $class, $key ) = @_;\n\n\tbless my $self = {\n\t\ttype => 'tree',\n\t\tsha  => $key,\n\t\tent  => []\n\t} => $class;\n\n\tmy $raw = GIT::cmdout( 'git-cat-file', 'tree', $key );\n\n\tmy @raw = unpack( '(Z*H40)*', $raw ); \n\t$raw = undef;\n\twhile ( @raw ) {\n\t\tpush @{ $self->{ ent } },\n\t\t\t[ split( ' ', shift @raw, 2 ), shift @raw ];\n\t}\n\n\treturn $self;\n}\n\npackage GIT::ObjectDB::Tag;\nuse strict;\nuse Carp qw( croak );\n\nsub new {\n\tmy $class  = shift;\n\tmy $object = shift             || croak \"Missing object\";\n\t$object =~ /^[A-Za-z0-9]{40}$/ || croak \"Invalid object id\";\n\tmy $tag    = shift             || croak \"Missing tag\";\n\tmy $sig    = shift             || croak \"Missing signature\";\n\n\treturn bless {\n\t\ttype   => 'tag',\n\t\tobject => $object,\n\t\ttag    => $tag,\n\t\tsig    => $sig\n\t} => $class;\n}\n\nsub new_fromkey {\n\tmy ( $class, $key ) = @_;\n\tbless my $self = {\n\t\ttype => 'tag',\n\t\tsha  => $key,\n\t\tsig  => ''\n\t} => $class;\n  \n\tlocal $/ = \"\\n\";\n\tGIT::cmdout( sub {\n\t\tif ( /^object ([A-Za-z0-9]{40})$/ ) {\n\t\t\t$self->{ object } = $1;\n\t\t} elsif ( /^type (.+)$/ ) {\n\t\t\t$self->{ object_type } = $1;\n\t\t} elsif ( /^tag (.+)$/ ) {\n\t\t\t$self->{ tag } = $1;\n\t\t} else {\n\t\t\t$self->{ sig } .= $_;\n\t\t}\n\t\treturn 0;\n\t}, 'git-cat-file', 'tag', $key );\n\n\treturn $self;\n}\n"}]}