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
        &Tree_Mkdir
        &Monitor_Incoming
        &PoolBasePath
        &PoolDir
        &Scan_Changes
        &Scan_All
        &Strip_Subsection
    );

    %EXPORT_TAGS = (
        'functions' => [qw(&Archfile &Create_Tree &Tree_Mkdir &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;
        }
    }

    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: