Subversion Repositories

?revision_form?Rev ?revision_input??revision_submit??revision_endform?

Rev 1 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
1 magnus 1
package DebPool::Dirs;
2
 
3
###
4
#
5
# DebPool::Dirs - Module for dealing with directory related tasks
6
#
7
# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
8
# 
9
# Redistribution and use in source and binary forms, with or without
10
# modification, are permitted provided that the following conditions
11
# are met:
12
# 1. Redistributions of source code must retain the above copyright
13
#    notice, this list of conditions and the following disclaimer.
14
# 2. Redistributions in binary form must reproduce the above copyright
15
#    notice, this list of conditions and the following disclaimer in the
16
#    documentation and/or other materials provided with the distribution.
17
# 3. Neither the name of the Author nor the names of any contributors
18
#    may be used to endorse or promote products derived from this software
19
#    without specific prior written permission.
20
# 
21
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
22
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24
# ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
25
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
26
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
27
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
29
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
30
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
31
# SUCH DAMAGE.
32
#
33
# $Id: Dirs.pm 71 2006-06-26 21:16:01Z joel $
34
#
35
###
36
 
37
# We use 'our', so we must have at least Perl 5.6
38
 
39
require 5.006_000;
40
 
41
# Always good ideas.
42
 
43
use strict;
44
use warnings;
45
 
46
### Module setup
47
 
48
BEGIN {
49
    use Exporter ();
50
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
51
 
52
    # Version checking
53
    $VERSION = '0.1.5';
54
 
55
    @ISA = qw(Exporter);
56
 
57
    @EXPORT = qw(
58
    );
59
 
60
    @EXPORT_OK = qw(
61
        &Archfile
62
        &Create_Tree
63
        &Monitor_Incoming
64
        &PoolBasePath
65
        &PoolDir
66
        &Scan_Changes
67
        &Scan_All
68
        &Strip_Subsection
69
    );
70
 
71
    %EXPORT_TAGS = (
72
        'functions' => [qw(&Archfile &Create_Tree &Monitor_Incoming
73
                           &PoolBasePath &PoolDir &Scan_Changes &Scan_All
74
                           &Strip_Subsection)],
75
        'vars' => [qw()],
76
    );
77
}
78
 
79
### Exported package globals
80
 
81
# None
82
 
83
### Non-exported package globals
84
 
85
# Thread-safe? What's that? Package global error value. We don't export
86
# this directly, because it would conflict with other modules.
87
 
88
our($Error);
89
 
90
### File lexicals
91
 
92
# None
93
 
94
### Constant functions
95
 
96
# None
97
 
98
### Meaningful functions
99
 
100
# Create_Tree()
101
#
102
# Creates a full directory tree based on the current directory values in
103
# %DebPool::Config::Options. Returns 1 on success, 0 on failure (and sets
104
# or propagates $Error).
105
 
106
sub Create_Tree {
107
    use DebPool::Config qw(:vars);
108
 
109
    # Basic directories - none of these are terribly exciting. We don't set
110
    # $Error on failure, because Tree_Mkdir will have already done so.
111
 
112
    if (!Tree_Mkdir($Options{'db_dir'}, $Options{'db_dir_mode'})) {
113
        return 0;
114
    }
115
 
116
    if (!Tree_Mkdir($Options{'incoming_dir'}, $Options{'incoming_dir_mode'})) {
117
        return 0;
118
    }
119
 
120
    if (!Tree_Mkdir($Options{'installed_dir'}, $Options{'installed_dir_mode'})) {
121
        return 0;
122
    }
123
 
124
    if (!Tree_Mkdir($Options{'reject_dir'}, $Options{'reject_dir_mode'})) {
125
        return 0;
126
    }
127
 
128
    # Now the distribution directory and subdirectories
129
 
130
    my($dists_dir) = $Options{'dists_dir'};
131
    my($dists_dir_mode) = $Options{'dists_dir_mode'};
132
 
133
    if (!Tree_Mkdir($dists_dir, $dists_dir_mode)) {
134
        return 0;
135
    }
136
 
137
    # Real distributions are the only ones that get directories.
138
 
139
    my($dist);
140
    foreach $dist (@{$Options{'realdists'}}) {
141
        if (!Tree_Mkdir("$dists_dir/$dist", $dists_dir_mode)) {
142
            return 0;
143
        }
144
 
145
        my($section);
146
        foreach $section (@{$Options{'sections'}}) {
147
            if (!Tree_Mkdir("$dists_dir/$dist/$section", $dists_dir_mode)) {
148
                return 0;
149
            }
150
 
151
            my($arch);
152
            foreach $arch (@{$Options{'archs'}}) {
153
                my($target) = "$dists_dir/$dist/$section/";
154
                if ('source' eq $arch) {
155
                    $target .= $arch;
156
                } else {
157
                    $target .= "binary-$arch";
158
                }
159
 
160
                if (!Tree_Mkdir($target, $dists_dir_mode)) {
161
                    return 0;
162
                }
163
            }
164
        }
165
    }
166
 
167
    # Go through all of the distributions looking for those that should be
168
    # symlinks, and creating them if necessary.
169
 
170
    foreach $dist (keys(%{$Options{'dists'}})) {
171
        # Check whether it should be a symlink. If so, make sure it is.
172
 
173
        if (!($dist eq $Options{'dists'}->{$dist})) { # Different names -> sym
174
            if (! -e "$dists_dir/$dist") {
175
                if (!symlink($Options{'dists'}->{$dist}, "$dists_dir/$dist")) {
176
                    $Error = "Couldn't create symlink $dists_dir/$dist -> ";
177
                    $Error .= "$Options{'dists'}->{$dist}: $!";
178
                }
179
            } elsif (! -l "$dists_dir/$dist") {
180
                $Error = "$dists_dir/$dist exists and isn't a symlink, ";
181
                $Error .= "but it should be";
182
                return 0;
183
            }
184
        }
185
    }
186
 
187
    # And, finally, the pool directories and their subdirectories
188
 
189
    my($pool_dir) = $Options{'pool_dir'};
190
    my($pool_dir_mode) = $Options{'pool_dir_mode'};
191
 
192
    if (!Tree_Mkdir($pool_dir, $pool_dir_mode)) {
193
        return 0;
194
    }
195
 
196
    # We can only get away with this because Debian pool directories are
197
    # named in ASCII...
198
 
199
    my($section);
200
    foreach $section (@{$Options{'sections'}}) {
201
        if (!Tree_Mkdir("$pool_dir/$section", $pool_dir_mode)) {
202
            return 0;
203
        }
204
 
205
        my($letter);
206
        foreach $letter ('a' .. 'z') {
207
            if (!Tree_Mkdir("$pool_dir/$section/$letter", $pool_dir_mode)) {
208
                return 0;
209
            }
210
            if (!Tree_Mkdir("$pool_dir/$section/lib$letter", $pool_dir_mode)) {
211
                return 0;
212
            }
213
        }
214
    }
215
 
216
    return 1;
217
}
218
 
219
# Tree_Mkdir($directory, $mode)
220
#
221
# Creates $directory with $mode. Returns 0 and sets $Error on failure, or
222
# 1 on success.
223
#
224
# Internal support function for Create_Tree
225
 
226
sub Tree_Mkdir {
227
    my($dir, $mode) = @_;
228
 
229
    if (-d $dir) {
230
        return 1;
231
    };
232
 
233
    if (-e $dir) {
234
        $Error = "Couldn't create '$dir' - already exists as a non-directory.";
235
        return 0;
236
    }
237
 
238
    if (!mkdir($dir, $mode)) {
239
        $Error = "Couldn't create '$dir': $!";
240
        return 0;
241
    }
242
 
243
    if (!chmod($mode, $dir)) {
244
        $Error = "Couldn't chmod '$dir': $!";
245
        return 0;
246
    }
247
 
248
    return 1;
249
}
250
 
251
# Scan_Changes($directory)
252
#
253
# Scan the specified directory for changes files. Returns an array of
254
# filenames relative to the directory, or undef (and sets $Error) on an error.
255
 
256
sub Scan_Changes {
257
    my($directory) = @_;
258
 
259
    if (!opendir(INCOMING, $directory)) {
260
        $Error = "Couldn't open directory '$directory': $!";
261
        return undef;
262
    }
263
 
264
    # Perl magic - read the directory and grep it for *.changes all at one
265
    # shot.
266
 
267
    my(@changes) = grep(/\.changes$/, readdir(INCOMING));
268
    close(INCOMING);
269
 
270
    return @changes;
271
}
272
 
273
# Scan_All($directory)
274
#
275
# Scans the specified directory and all subdirectories for any files.
276
# Returns an arrayref pointing to an array of filepaths relative to
277
# $directory, or undef (and sets $Error) on failure. Ignores any hidden
278
# files or directories.
279
 
280
sub Scan_All {
281
    my($directory) = @_;
282
 
283
    if (!opendir(DIR, $directory)) {
284
        $Error = "Couldn't open directory '$directory'";
285
        return undef;
286
    }
287
 
288
    my($direntry);
289
    my(@entries) = grep(!/^\./, readdir(DIR));
290
 
291
    my(@return);
292
 
293
    foreach $direntry (@entries) {
294
        if (-f "$directory/$direntry") {
295
            push(@return, $direntry);
296
        } elsif (-d "$directory/$direntry") {
297
            my($recurse) = Scan_All("$directory/$direntry");
298
 
299
            if (!defined($recurse)) { # $Error is already set.
300
                return undef;
301
            }
302
 
303
            # I'd like to use map(), but Perl makes stooopid guesses.
304
 
305
            my($entry);
306
 
307
            foreach $entry (@{$recurse}) {
308
                push(@return, "$direntry/$entry");
309
            }
310
        }
311
    }
312
 
313
    return \@return;
314
}
315
 
316
# Monitor_Incoming()
317
#
318
# Monitors the incoming directory, looping until the directory is updated.
319
# Returns 1 on success, 0 on failure (and sets $Error).
320
 
321
sub Monitor_Incoming {
322
    use DebPool::Config;
323
    use DebPool::Logging qw(:functions :facility :level);
324
 
325
    # If this is ever false, we either shouldn't have been called in the
326
    # first place, or we've caught a signal and shouldn't do anything
327
    # further.
328
 
329
    if ($DebPool::Signal::Signal_Caught) {
330
        return 1;
331
    }
332
 
333
    my(@stat) = stat($Options{'incoming_dir'});
334
    if (!@stat) {
335
        $Error = "Couldn't stat incoming_dir '$Options{'incoming_dir'}'";
336
        return 0;
337
    }
338
    my($mtime) = $stat[9];
339
 
340
    do {
341
        Log_Message("Incoming monitor: sleeping for " .
342
            $Options{'sleep'} . " seconds", LOG_GENERAL, LOG_DEBUG);
343
        sleep($Options{'sleep'});
344
        @stat = stat($Options{'incoming_dir'});
345
        if (!@stat) {
346
            $Error = "Couldn't stat incoming_dir '$Options{'incoming_dir'}'";
347
            return 0;
348
        }
349
    } until (($stat[9] != $mtime) || ($DebPool::Signal::Signal_Caught));
350
 
351
    return 1;
352
}
353
 
354
# PoolDir($name, $section, $archive_base)
355
#
356
# Calculates a pool subdirectory name from the package name and the section
357
# (if provided; assumed to be 'main' if undefined or unrecognized).
358
 
359
sub PoolDir {
360
    my($name, $section, $archive_base) = @_;
361
 
362
    $section = Strip_Subsection($section);
363
 
364
    # Pool subdirectories are normally the first letter of the package
365
    # name, unless it is a lib* package, in which case the subdir is
366
    # lib<first letter>.
367
 
368
    if ($name =~ s/^lib//) { # lib(.).*
369
        return $section . '/' . 'lib' . substr($name, 0, 1);
370
    } else { # (.).*
371
        return $section . '/' . substr($name, 0, 1);
372
    }
373
}
374
 
375
# Strip_Subsection($section)
376
#
377
# This routine could, perhaps, better named. However, the purpose is to
378
# take a Section header as found in a package, and return the 'section'
379
# (rather than [section/]subsection) of it - that is, 'main', 'contrib', or
380
# 'non-free' (normally; it uses the configuration options to track this).
381
#
382
# Any unrecognized section is assumed to be 'main'; section values without
383
# *any* subsection portion succeed, as well (at least, assuming that they
384
# are otherwise valid).
385
 
386
sub Strip_Subsection {
387
    use DebPool::Config qw(:vars);
388
 
389
    my($section) = @_;
390
 
391
    if (!defined($section)) {
392
        return 'main';
393
    }
394
 
395
    my($check_section);
396
    foreach $check_section (@{$Options{'sections'}}) {
397
        if ($section =~ m/^$check_section(\/.+)?$/) {
398
            return $check_section;
399
        }
400
    }
401
 
402
    return 'main';
403
}
404
 
405
# PoolBasePath()
406
#
407
# Calculates the value of the relative path from archive_dir to pool_dir
408
# (this is primarily useful when having to provide file paths relative to
409
# archive_dir, such as in Packages/Sources files). This does assume that
410
# pool_dir is a subdirectory of archive_dir, but if that isn't true then
411
# things are royally screwed up *anyway*...
412
 
413
sub PoolBasePath {
414
    use DebPool::Config qw(:vars);
415
 
416
    my($path) = $Options{'pool_dir'};
417
    $path =~ s/^$Options{'archive_dir'}\///;
418
    return $path;
419
}
420
 
421
# Archfile($archive, $component, $architecture, $dironly)
422
#
423
# Returns the file name for the Packages/Sources file, or the directory
424
# name of the arch directory if $dironly is true, (from a base of
425
# dists_dir) for the specified archive, component, and architecture.
426
 
427
sub Archfile {
428
    my($archive) = shift(@_);
429
    my($component) = shift(@_);
430
    my($architecture) = shift(@_);
431
    my($dironly) = shift(@_);
432
 
433
    my($result) = "$archive/$component";
434
 
435
    my($type);
436
    if ('source' eq $architecture) {
437
        $result .= "/${architecture}";
438
        $type = "Sources";
439
    } else {
440
        $result .= "/binary-${architecture}";
441
        $type = "Packages";
442
    }
443
 
444
    if (!$dironly) {
445
        $result .= "/${type}";
446
    }
447
 
448
    return $result;
449
}
450
 
451
END {}
452
 
453
1;
454
 
455
__END__
456
 
457
# vim:set tabstop=4 expandtab: