1#**************************************************************
2#
3#  Licensed to the Apache Software Foundation (ASF) under one
4#  or more contributor license agreements.  See the NOTICE file
5#  distributed with this work for additional information
6#  regarding copyright ownership.  The ASF licenses this file
7#  to you under the Apache License, Version 2.0 (the
8#  "License"); you may not use this file except in compliance
9#  with the License.  You may obtain a copy of the License at
10#
11#    http://www.apache.org/licenses/LICENSE-2.0
12#
13#  Unless required by applicable law or agreed to in writing,
14#  software distributed under the License is distributed on an
15#  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
16#  KIND, either express or implied.  See the License for the
17#  specific language governing permissions and limitations
18#  under the License.
19#
20#**************************************************************
21
22
23
24#*************************************************************************
25#
26# RepositoryHelper - Perl for working with repositories and underlying SCM
27#
28# usage: see below
29#
30#*************************************************************************
31
32package RepositoryHelper;
33
34use strict;
35
36
37use Carp;
38use Cwd qw (cwd);
39use File::Basename;
40#use File::Temp qw(tmpnam);
41
42my $debug = 0;
43
44#####  profiling #####
45
46##### ctor #####
47
48sub new {
49    my $proto = shift;
50    my $class = ref($proto) || $proto;
51    my $initial_directory = shift;
52    if ($initial_directory) {
53        $initial_directory = Cwd::realpath($initial_directory);
54    } else {
55        if ( defined $ENV{PWD} ) {
56            $initial_directory = $ENV{PWD};
57        } elsif (defined $ENV{_cwd}) {
58            $initial_directory = $ENV{_cwd};
59        } else {
60            $initial_directory = cwd();
61        };
62    };
63    my $self = {};
64    $self->{INITIAL_DIRECTORY} = $initial_directory;
65    $self->{REPOSITORY_ROOT} = undef;
66    $self->{REPOSITORY_NAME} = undef;
67    $self->{SCM_NAME} = undef;
68    detect_repository($self);
69    bless($self, $class);
70    return $self;
71}
72
73##### methods #####
74sub get_repository_root
75{
76    my $self        = shift;
77    return $self->{REPOSITORY_ROOT};
78}
79
80sub get_initial_directory
81{
82    my $self        = shift;
83    return $self->{INITIAL_DIRECTORY};
84}
85
86sub get_scm_name
87{
88    my $self        = shift;
89    return$self->{SCM_NAME};
90}
91
92##### private methods #####
93sub search_for_hg {
94    my $self        = shift;
95    my $hg_root;
96    my $scm_name = 'hg';
97    if (open(COMMAND, "$scm_name root 2>&1 |")) {
98        foreach (<COMMAND>) {
99            next if (/^Not trusting file/);
100            chomp;
101            $hg_root = $_;
102            last;
103        };
104        close COMMAND;
105        chomp $hg_root;
106        if ($hg_root !~ /There is no Mercurial repository here/) {
107            $self->{REPOSITORY_ROOT} = $hg_root;
108            $self->{SCM_NAME} = $scm_name;
109            return 1;
110        };
111    };
112    return 0;
113};
114
115sub search_via_build_lst {
116    my $self = shift;
117#    my @possible_build_lists = ('build.lst', 'build.xlist'); # build lists names
118    my @possible_build_lists = ('build.lst'); # build lists names
119    my $previous_dir = '';
120    my $rep_root_candidate = $self->{INITIAL_DIRECTORY};
121    do {
122        foreach (@possible_build_lists) {
123            my $test_file;
124            if ($rep_root_candidate eq '/') {
125                $test_file = '/prj/' . $_;
126            } else {
127                $test_file = $rep_root_candidate . '/prj/' . $_;
128            };
129            if (-e $test_file) {
130                $self->{REPOSITORY_ROOT} = File::Basename::dirname($rep_root_candidate);
131                return 1;
132            };
133        };
134        $previous_dir = $rep_root_candidate;
135        $rep_root_candidate = File::Basename::dirname(Cwd::realpath($rep_root_candidate));
136        return 0 if ((!$rep_root_candidate) || ($rep_root_candidate eq $previous_dir));
137    }
138    while (chdir "$rep_root_candidate");
139};
140
141sub detect_repository {
142    my $self        = shift;
143    return if (search_via_build_lst($self));
144    chdir $self->{INITIAL_DIRECTORY};
145    return if (search_for_hg($self));
146    croak('Cannot determine source directory/repository for ' . $self->{INITIAL_DIRECTORY});
147};
148
149##### finish #####
150
1511; # needed by use or require
152
153__END__
154
155=head1 NAME
156
157RepositoryHelper - Perl module for working with repositories and underlying SCM
158
159=head1 SYNOPSIS
160
161    # example that will analyze sources and return the source root directory
162
163    use RepositoryHelper;
164
165    # Create a new instance:
166    $a = RepositoryHelper->new();
167
168    # Get repositories for the actual workspace:
169    $a->get_repository_root();
170
171
172=head1 DESCRIPTION
173
174RepositoryHelper is a perlPerl module for working with repositories and underlying SCM
175in the database.
176
177Methods:
178
179RepositoryHelper::new()
180
181Creates a new instance of RepositoryHelper. Can be initialized by: some path which likely to belong to a repository, default - empty, the current dir will be taken.
182
183RepositoryHelper::get_repository_root()
184
185Returns the repository root, retrieved by SCM methods or on educated guess...
186
187RepositoryHelper::get_initial_directory()
188
189Returns full path to the initialistion directory.
190
191=head2 EXPORT
192
193RepositoryHelper::new()
194RepositoryHelper::get_repository_root()
195RepositoryHelper::get_scm_name()
196RepositoryHelper::get_initial_directory()
197
198=head1 AUTHOR
199
200Vladimir Glazunov, vg@openoffice.org
201
202=head1 SEE ALSO
203
204perl(1).
205
206=cut
207