The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package GitStore;

use Moose;
use Git::PurePerl;
use Storable qw(nfreeze thaw);

our $VERSION = '0.05';
our $AUTHORITY = 'cpan:FAYLAND';

has 'repo' => ( is => 'ro', isa => 'Str', required => 1 );
has 'branch' => ( is => 'rw', isa => 'Str', default => 'master' );
has 'author' => ( is => 'rw', isa => 'Str', default => 'Fayland Lam <fayland\@gmail.com>' );

has 'head_directory_entries' => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );
has 'root' => ( is => 'rw', isa => 'HashRef', default => sub { {} } );
has 'to_add' => ( is => 'rw', isa => 'HashRef', default => sub { {} } );
has 'to_delete' => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );

has 'git' => (
    is => 'ro',
    isa => 'Git::PurePerl',
    lazy => 1,
    default => sub {
        Git::PurePerl->new( directory =>  shift->repo );
    }
);

sub BUILD {
    my $self = shift;
    
    $self->load();
    
}

sub BUILDARGS {
    my $class = shift;

    if ( @_ == 1 && ! ref $_[0] ) {
        return { repo => $_[0] };
    } else {
        return $class->SUPER::BUILDARGS(@_);
    }
}

# Load the current head version from repository. 
sub load {
    my $self = shift;
    
    my $head = $self->git->ref_sha1('refs/heads/' . $self->branch);
    if ( $head ) {
        my $commit = $self->git->get_object($head);
        my $tree = $commit->tree;
        my @directory_entries = $tree->directory_entries;
        $self->head_directory_entries(\@directory_entries); # for delete
        my $root = {};
        foreach my $d ( @directory_entries ) {
            $root->{ $d->filename } = _cond_thaw( $d->object->content );
        }
        $self->root($root);
    }
}

sub get {
    my ( $self, $path ) = @_;
    
    $path = join('/', @$path) if ref $path eq 'ARRAY';

    if ( grep { $_ eq $path } @{$self->to_delete} ) {
        return;
    }
    if ( exists $self->to_add->{ $path } ) {
        return $self->to_add->{ $path };
    }
    if ( exists $self->root->{ $path } ) {
        return $self->root->{ $path };
    }
    
    return;
}

sub set {
    my ( $self, $path, $content ) = @_;
    
    $path = join('/', @$path) if ref $path eq 'ARRAY';
    $self->{to_add}->{$path} = $content;
}

*remove = \&delete;
sub delete {
    my ( $self, $path ) = @_;
    
    $path = join('/', @$path) if ref $path eq 'ARRAY';
    push @{$self->{to_delete}}, $path;
    
}

sub commit {
    my ( $self, $message ) = @_;
    
    return unless ( scalar keys %{$self->{to_add}} or scalar @{$self->to_delete} );

    my @new_de;
    my @directory_entries = @{ $self->head_directory_entries };
    # remove those need deleted or added
    foreach my $d ( @directory_entries ) {
        next if ( grep { $d->filename eq $_ } @{ $self->to_delete } );
        next if ( grep { $d->filename eq $_ } keys %{ $self->to_add } );
        push @new_de, Git::PurePerl::NewDirectoryEntry->new(
            mode     => '100644',
            filename => $d->filename,
            sha1     => $d->sha1,
        );;
    }
    # for add those new
    foreach my $path ( keys %{$self->{to_add}} ) {
        my $content = $self->to_add->{$path};
        $content = nfreeze( $content ) if ( ref $content );
        my $blob = Git::PurePerl::NewObject::Blob->new( content => $content );
        $self->git->put_object($blob);
        my $de = Git::PurePerl::NewDirectoryEntry->new(
            mode     => '100644',
            filename => $path,
            sha1     => $blob->sha1,
        );
        push @new_de, $de;
    }
    
    # commit
    my $tree = Git::PurePerl::NewObject::Tree->new(
        directory_entries => \@new_de,
    );
    $self->git->put_object($tree);
    
    my $content = $self->_build_my_content( $tree->sha1, $message || 'Your Comments Here' );
    my $commit = Git::PurePerl::NewObject::Commit->new(
        tree => $tree->sha1,
        content => $content
    );
    $self->git->put_object($commit);

    # reload
    $self->{to_add} = {};
    $self->{to_delete} = [];
    $self->load;
}

sub discard {
    my $self = shift;
    
    $self->{to_add} = {};
    $self->{to_delete} = [];
    $self->load;
}

sub _build_my_content {
    my ( $self, $tree, $message ) = @_;
    
    my $author = $self->author;
    my $time = time();
    
    my $content;
    $content .= "tree $tree\n";
    $content .= "author $author $time +0000\n";
    $content .= "committer $author $time +0000\n";
    $content .= "\n";
    $content .= "$message\n";
    return $content;
}

sub _cond_thaw {
    my $data = shift;

    my $magic = eval { Storable::read_magic($data); };
    if ($magic && $magic->{major} && $magic->{major} >= 2 && $magic->{major} <= 5) {
        my $thawed = eval { Storable::thaw($data) };
        if ($@) {
            # false alarm... looked like a Storable, but wasn't.
            return $data;
        }
        return $thawed;
    } else {
        return $data;
    }
}

no Moose;
__PACKAGE__->meta->make_immutable;

1;
__END__

=head1 NAME

GitStore - Git as versioned data store in Perl

=head1 SYNOPSIS

    use GitStore;

    my $gs = GitStore->new('/path/to/repo');
    $gs->set( 'users/obj.txt', $obj );
    $gs->set( ['config', 'wiki.txt'], { hash_ref => 1 } );
    $gs->commit();
    $gs->set( 'yyy/xxx.log', 'Log me' );
    $gs->discard();
    
    # later or in another pl
    my $val = $gs->get( 'user/obj.txt' ); # $val is the same as $obj
    my $val = $gs->get( 'config/wiki.txt' ); # $val is { hashref => 1 } );
    my $val = $gs->get( ['yyy', 'xxx.log' ] ); # $val is undef since discard
    

=head1 DESCRIPTION

It is inspired by the Python and Ruby binding. check SEE ALSO

=head1 METHODS

=head2 new

    GitStore->new('/path/to/repo');
    GitStore->new( repo => '/path/to/repo', branch => 'mybranch' );
    GitStore->new( repo => '/path/to/repo', author => 'Someone Unknown <unknown\@what.com>' );

=over 4

=item repo

your git dir (without .git)

=item branch

your branch name, default is 'master'

=item author

It is used in the commit info

=back

=head2 set($path, $val)

    $gs->set( 'yyy/xxx.log', 'Log me' );
    $gs->set( ['config', 'wiki.txt'], { hash_ref => 1 } );
    $gs->set( 'users/obj.txt', $obj );

Store $val as a $path file in Git

$path can be String or ArrayRef

$val can be String or Ref[HashRef|ArrayRef|Ref[Ref]] or blessed Object

=head2 get($path)

    $gs->get( 'user/obj.txt' );
    $gs->get( ['yyy', 'xxx.log' ] );

Get $val from the $path file

$path can be String or ArrayRef

=head2 delete($path)

=head2 remove($path)

remove $path from Git store

=head2 commit

    $gs->commit();
    $gs->commit('Your Comments Here');

commit the B<set> changes into Git

=head2 discard

    $gs->discard();

discard the B<set> changes

=head1 FAQ

=head2 why the files are B<not> there?

run

    git checkout

=head2 any example?

    # if you just need a local repo, that's all you need.
    mkdir sandbox
    cd sandbox
    git init
    # use GitStore->new('/path/to/this/sandbox')
    # set something
    git checkout
    
    # follows are for remote git url
    git remote add origin git@github.com:fayland/sandbox2.git
    git push origin master
    # do more GitStore->new('/path/to/this/sandbox') later
    git checkout
    git pull origin master
    git push

=head1 SEE ALSO

=over 4

=item Article

L<http://www.newartisans.com/2008/05/using-git-as-a-versioned-data-store-in-python.html>

=item Python binding

L<http://github.com/jwiegley/git-issues/tree/master>

=item Ruby binding

L<http://github.com/georgi/git_store/tree/master>

=back

=head1 Git URL

L<http://github.com/fayland/perl-git-store/tree/master>

=head1 AUTHOR

Fayland Lam, C<< <fayland at gmail.com> >>

=head1 COPYRIGHT & LICENSE

Copyright 2009 Fayland Lam, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.