Subversion Repositories

package DebPool::Dirs;

###

#

# DebPool::Dirs - Module for dealing with directory related tasks

#

# Copyright 2003-2004 Joel Aelwyn. All rights reserved.

# 

# Redistribution and use in source and binary forms, with or without

# modification, are permitted provided that the following conditions

# are met:

# 1. Redistributions of source code must retain the above copyright

#    notice, this list of conditions and the following disclaimer.

# 2. Redistributions in binary form must reproduce the above copyright

#    notice, this list of conditions and the following disclaimer in the

#    documentation and/or other materials provided with the distribution.

# 3. Neither the name of the Author nor the names of any contributors

#    may be used to endorse or promote products derived from this software

#    without specific prior written permission.

# 

# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND

# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE

# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE

# ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE

# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS

# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)

# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT

# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY

# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF

# SUCH DAMAGE.

#

# $Id: Dirs.pm 71 2006-06-26 21:16:01Z joel $

#

###

# We use 'our', so we must have at least Perl 5.6

require 5.006_000;

# Always good ideas.

use strict;

use warnings;

### Module setup

BEGIN {

    use Exporter ();

    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

    # Version checking

    $VERSION = '0.1.5';

    @ISA = qw(Exporter);

    @EXPORT = qw(

    );

    @EXPORT_OK = qw(

        &Archfile

        &Create_Tree

        &Monitor_Incoming

        &PoolBasePath

        &PoolDir

        &Scan_Changes

        &Scan_All

        &Strip_Subsection

    );

    %EXPORT_TAGS = (

        'functions' => [qw(&Archfile &Create_Tree &Monitor_Incoming

                           &PoolBasePath &PoolDir &Scan_Changes &Scan_All

                           &Strip_Subsection)],

        'vars' => [qw()],

    );

}

### Exported package globals

# None

### Non-exported package globals

# Thread-safe? What's that? Package global error value. We don't export

# this directly, because it would conflict with other modules.

our($Error);

### File lexicals

# None

### Constant functions

# None

### Meaningful functions

# Create_Tree()

#

# Creates a full directory tree based on the current directory values in

# %DebPool::Config::Options. Returns 1 on success, 0 on failure (and sets

# or propagates $Error).

sub Create_Tree {

    use DebPool::Config qw(:vars);

    # Basic directories - none of these are terribly exciting. We don't set

    # $Error on failure, because Tree_Mkdir will have already done so.

    if (!Tree_Mkdir($Options{'db_dir'}, $Options{'db_dir_mode'})) {

        return 0;

    }

    if (!Tree_Mkdir($Options{'incoming_dir'}, $Options{'incoming_dir_mode'})) {

        return 0;

    }

    if (!Tree_Mkdir($Options{'installed_dir'}, $Options{'installed_dir_mode'})) {

        return 0;

    }

    if (!Tree_Mkdir($Options{'reject_dir'}, $Options{'reject_dir_mode'})) {

        return 0;

    }

    # Now the distribution directory and subdirectories

    my($dists_dir) = $Options{'dists_dir'};

    my($dists_dir_mode) = $Options{'dists_dir_mode'};

    if (!Tree_Mkdir($dists_dir, $dists_dir_mode)) {

        return 0;

    }

    # Real distributions are the only ones that get directories.

    my($dist);

    foreach $dist (@{$Options{'realdists'}}) {

        if (!Tree_Mkdir("$dists_dir/$dist", $dists_dir_mode)) {

            return 0;

        }

        my($section);

        foreach $section (@{$Options{'sections'}}) {

            if (!Tree_Mkdir("$dists_dir/$dist/$section", $dists_dir_mode)) {

                return 0;

            }

            my($arch);

            foreach $arch (@{$Options{'archs'}}) {

                my($target) = "$dists_dir/$dist/$section/";

                if ('source' eq $arch) {

                    $target .= $arch;

                } else {

                    $target .= "binary-$arch";

                }

                if (!Tree_Mkdir($target, $dists_dir_mode)) {

                    return 0;

                }

            }

        }

    }

    # Go through all of the distributions looking for those that should be

    # symlinks, and creating them if necessary.

    foreach $dist (keys(%{$Options{'dists'}})) {

        # Check whether it should be a symlink. If so, make sure it is.

        if (!($dist eq $Options{'dists'}->{$dist})) { # Different names -> sym

            if (! -e "$dists_dir/$dist") {

                if (!symlink($Options{'dists'}->{$dist}, "$dists_dir/$dist")) {

                    $Error = "Couldn't create symlink $dists_dir/$dist -> ";

                    $Error .= "$Options{'dists'}->{$dist}: $!";

                }

            } elsif (! -l "$dists_dir/$dist") {

                $Error = "$dists_dir/$dist exists and isn't a symlink, ";

                $Error .= "but it should be";

                return 0;

            }

        }

    }

    # And, finally, the pool directories and their subdirectories

    my($pool_dir) = $Options{'pool_dir'};

    my($pool_dir_mode) = $Options{'pool_dir_mode'};

    if (!Tree_Mkdir($pool_dir, $pool_dir_mode)) {

        return 0;

    }

    # We can only get away with this because Debian pool directories are

    # named in ASCII...

    my($section);

    foreach $section (@{$Options{'sections'}}) {

        if (!Tree_Mkdir("$pool_dir/$section", $pool_dir_mode)) {

            return 0;

        }

        my($letter);

        foreach $letter ('a' .. 'z') {

            if (!Tree_Mkdir("$pool_dir/$section/$letter", $pool_dir_mode)) {

                return 0;

            }

            if (!Tree_Mkdir("$pool_dir/$section/lib$letter", $pool_dir_mode)) {

                return 0;

            }

        }

    }

    return 1;

}

# Tree_Mkdir($directory, $mode)

#

# Creates $directory with $mode. Returns 0 and sets $Error on failure, or

# 1 on success.

#

# Internal support function for Create_Tree

sub Tree_Mkdir {

    my($dir, $mode) = @_;

    if (-d $dir) {

        return 1;

    };

    if (-e $dir) {

        $Error = "Couldn't create '$dir' - already exists as a non-directory.";

        return 0;

    }

    if (!mkdir($dir, $mode)) {

        $Error = "Couldn't create '$dir': $!";

        return 0;

    }

    if (!chmod($mode, $dir)) {

        $Error = "Couldn't chmod '$dir': $!";

        return 0;

    }

    return 1;

}

# Scan_Changes($directory)

#

# Scan the specified directory for changes files. Returns an array of

# filenames relative to the directory, or undef (and sets $Error) on an error.

sub Scan_Changes {

    my($directory) = @_;

    if (!opendir(INCOMING, $directory)) {

        $Error = "Couldn't open directory '$directory': $!";

        return undef;

    }

    # Perl magic - read the directory and grep it for *.changes all at one

    # shot.

    my(@changes) = grep(/\.changes$/, readdir(INCOMING));

    close(INCOMING);

    return @changes;

}

# Scan_All($directory)

#

# Scans the specified directory and all subdirectories for any files.

# Returns an arrayref pointing to an array of filepaths relative to

# $directory, or undef (and sets $Error) on failure. Ignores any hidden

# files or directories.

sub Scan_All {

    my($directory) = @_;

    if (!opendir(DIR, $directory)) {

        $Error = "Couldn't open directory '$directory'";

        return undef;

    }

    my($direntry);

    my(@entries) = grep(!/^\./, readdir(DIR));

    my(@return);

    foreach $direntry (@entries) {

        if (-f "$directory/$direntry") {

            push(@return, $direntry);

        } elsif (-d "$directory/$direntry") {

            my($recurse) = Scan_All("$directory/$direntry");

            if (!defined($recurse)) { # $Error is already set.

                return undef;

            }

            # I'd like to use map(), but Perl makes stooopid guesses.

            my($entry);

            foreach $entry (@{$recurse}) {

                push(@return, "$direntry/$entry");

            }

        }

    }

    return \@return;

}

# Monitor_Incoming()

#

# Monitors the incoming directory, looping until the directory is updated.

# Returns 1 on success, 0 on failure (and sets $Error).

sub Monitor_Incoming {

    use DebPool::Config;

    use DebPool::Logging qw(:functions :facility :level);

    # If this is ever false, we either shouldn't have been called in the

    # first place, or we've caught a signal and shouldn't do anything

    # further.

    if ($DebPool::Signal::Signal_Caught) {

        return 1;

    }

    my(@stat) = stat($Options{'incoming_dir'});

    if (!@stat) {

        $Error = "Couldn't stat incoming_dir '$Options{'incoming_dir'}'";

        return 0;

    }

    my($mtime) = $stat[9];

    do {

        Log_Message("Incoming monitor: sleeping for " .

            $Options{'sleep'} . " seconds", LOG_GENERAL, LOG_DEBUG);

        sleep($Options{'sleep'});

        @stat = stat($Options{'incoming_dir'});

        if (!@stat) {

            $Error = "Couldn't stat incoming_dir '$Options{'incoming_dir'}'";

            return 0;

        }

    } until (($stat[9] != $mtime) || ($DebPool::Signal::Signal_Caught));

    return 1;

}

# PoolDir($name, $section, $archive_base)

#

# Calculates a pool subdirectory name from the package name and the section

# (if provided; assumed to be 'main' if undefined or unrecognized).

sub PoolDir {

    my($name, $section, $archive_base) = @_;

    $section = Strip_Subsection($section);

    # Pool subdirectories are normally the first letter of the package

    # name, unless it is a lib* package, in which case the subdir is

    # lib<first letter>.

    if ($name =~ s/^lib//) { # lib(.).*

        return $section . '/' . 'lib' . substr($name, 0, 1);

    } else { # (.).*

        return $section . '/' . substr($name, 0, 1);

    }

}

# Strip_Subsection($section)

#

# This routine could, perhaps, better named. However, the purpose is to

# take a Section header as found in a package, and return the 'section'

# (rather than [section/]subsection) of it - that is, 'main', 'contrib', or

# 'non-free' (normally; it uses the configuration options to track this).

#

# Any unrecognized section is assumed to be 'main'; section values without

# *any* subsection portion succeed, as well (at least, assuming that they

# are otherwise valid).

sub Strip_Subsection {

    use DebPool::Config qw(:vars);

    my($section) = @_;

    if (!defined($section)) {

        return 'main';

    }

    my($check_section);

    foreach $check_section (@{$Options{'sections'}}) {

        if ($section =~ m/^$check_section(\/.+)?$/) {

            return $check_section;

        }

    }

    return 'main';

}

# PoolBasePath()

#

# Calculates the value of the relative path from archive_dir to pool_dir

# (this is primarily useful when having to provide file paths relative to

# archive_dir, such as in Packages/Sources files). This does assume that

# pool_dir is a subdirectory of archive_dir, but if that isn't true then

# things are royally screwed up *anyway*...

sub PoolBasePath {

    use DebPool::Config qw(:vars);

    my($path) = $Options{'pool_dir'};

    $path =~ s/^$Options{'archive_dir'}\///;

    return $path;

}

# Archfile($archive, $component, $architecture, $dironly)

#

# Returns the file name for the Packages/Sources file, or the directory

# name of the arch directory if $dironly is true, (from a base of

# dists_dir) for the specified archive, component, and architecture.

sub Archfile {

    my($archive) = shift(@_);

    my($component) = shift(@_);

    my($architecture) = shift(@_);

    my($dironly) = shift(@_);

    my($result) = "$archive/$component";

    my($type);

    if ('source' eq $architecture) {

        $result .= "/${architecture}";

        $type = "Sources";

    } else {

        $result .= "/binary-${architecture}";

        $type = "Packages";

    }

    if (!$dironly) {

        $result .= "/${type}";

    }

    return $result;

}

END {}

1;

__END__

# vim:set tabstop=4 expandtab: