1 # 

     2 #  Simple perl interface to hg/mercurial.

     3 #

     4 

     5 package Logbuch::HG;

     6 

     7 use warnings;

     8 use strict;

     9 use Carp;

    10 use File::Which;

    11 use Cwd qw(cwd abs_path chdir);

    12 

    13 use fields qw(repo);

    14 use base qw(Class::Accessor::Fast);

    15 

    16 __PACKAGE__->follow_best_practice;

    17 __PACKAGE__->mk_accessors (qw(repo));

    18 

    19 # print output of external commands

    20 #

    21 my $external_output = 1;

    22 

    23 sub new { 

    24     my $class = shift;

    25 

    26     my $self = fields::new($class);

    27     my $args = { @_ };

    28 

    29     croak "no hg/mercurial binaries available" 

    30 	if not hg_available();

    31 

    32     croak "you should given an repository path"

    33 	if not defined $args->{repo};

    34 

    35     $self->set_repo($args->{repo});

    36 

    37     -d $self->get_repo() or croak "repository is no directory";

    38 

    39     return $self;

    40 }

    41 	

    42 =pod

    43 

    44 Check if given path is a repository

    45 

    46 =cut

    47 

    48 sub is_repository($) {

    49     my $self = shift;

    50 

    51     -d $self->get_repo() . "/.hg" or return 0;

    52 

    53     return 1;

    54 }

    55 

    56 

    57 sub init($) {

    58     my $self = shift;

    59     

    60     if ($self->is_repository()) {

    61 	carp "you are trying to initilize an already initilized repository, skipping";

    62 	return 1;

    63     }

    64 

    65     return _run($self->get_repo(), "hg init");

    66 }

    67 

    68 =pod

    69 

    70 Check if hg binaries are available.

    71 Static methode.

    72 

    73 =cut

    74 

    75 sub hg_available()

    76 {

    77     (not defined which('hg')) and return 0;

    78     return 1;

    79 }

    80 

    81 =pod

    82 

    83 Update working copy of repository.  Adds all new files, automatically

    84 removes no more existing files from repository.

    85 

    86 =cut

    87 sub addremove($)

    88 {

    89     my $self = shift;

    90 

    91     return _run( $self->get_repo(), "hg addremove" );

    92 }

    93 

    94 =pod

    95 

    96 Commit working copy to repository.

    97 

    98 =cut

    99 sub commit($;$) {

   100     my $self = shift;

   101     my $message = shift || "auto commit message";

   102 

   103     return _run( $self->get_repo(), "hg commit -m \"$message\"");

   104 }

   105 

   106 

   107 =pod

   108 

   109 Print status text of repository.

   110 

   111 NOTE: path names will be expanted to absoulte paths!!!

   112 

   113 =cut

   114 

   115 sub status($) {

   116     my $self = shift;

   117 

   118     my @result = _run( $self->get_repo(), "hg status");

   119 

   120     my $path = $self->get_repo() . "/";

   121     $result[1] =~ s/^([^\s]+)(\s+)(.*)$/${1}${2}${path}${3}/mg;

   122 

   123     return "$result[1]\n" if $result[1];

   124 }

   125 

   126 

   127 =pod

   128 

   129 Run shell command in modified environment:

   130 

   131  * cwd is changed to $self->repo

   132  * STDOUT and STDERR are caputred

   133  * return exit code

   134 

   135 =cut

   136 

   137 sub _run($$) {

   138     my $to_dir = shift;

   139     my $cmd = shift; 

   140     my $cwd = cwd();

   141     

   142     chdir($to_dir) or croak "cannot change to repository: $!";

   143 

   144     # redirect stderr to stdout 

   145     $cmd .= " 2>&1";

   146 

   147     my $output = `$cmd`;

   148     chomp $output;

   149 

   150     chdir($cwd) or croak "cannot chdir back from repository: $!";

   151 

   152     my $ret = ($? >> 8);

   153 

   154     if (wantarray) {

   155 	return ($ret, $output);

   156     }

   157 

   158     print "D: $output\n" if ("$output" and $external_output);

   159     return ($ret > 0) ? 0 : 1;

   160 }

   161 

   162 1;

   163 

   164 # vim: sw=4 sts=4 aw