Subversion Repositories DevTools

#! /usr/bin/perl
########################################################################
# Copyright (C) 2010 Vix-ERG Limited, All rights reserved
#
# Module name   : scan_release.pl
# Module type   : Makefile system
# Compiler(s)   : Perl
# Environment(s): jats
#
# Description   : Scan the Releases area looking for bad symlinks
#
#
#......................................................................#

require 5.008_002;
use strict;
use warnings;

my $root = $ARGV[0] || die ("Need to specify root directory");

#
#   Process ech directory
#
unless ( -d $root )
{
    print "scan_release: Not a directory: $root\n";
    exit 1;
}

scan_dir( $root );
exit 0;

#-------------------------------------------------------------------------------
# Function        : scan_dir
#
# Description     : Scan a list of directoires for bad links
#
# Inputs          : List of directories to scan
#
sub scan_dir
{
    foreach my $dir ( @_ )
    {
        my @dirs;
        my $dh;
#        print "Scanning: $dir\n";
        #
        #   Read in the directory entries
        #
        next if ( ! -d $dir );
        unless ( opendir($dh, $dir) )
        {   
            my  $mode = (stat($dir))[2];    
            printf("Cannot readdir $dir: $!, Mode:%04o\n", $mode & 07777);
            next;
        }
        my @entries = readdir($dh);
        closedir $dh;

        #
        #   Process each entry
        #
        foreach my $entry ( @entries )
        {
            next if ( $entry eq '.' );
            next if ( $entry eq '..' );
            next if ( $entry eq 'core_devl' );
            next if ( $entry eq 'lost+found' );

            $entry = "$dir/$entry";
            if ( -d $entry )
            {
                push @dirs, $entry;
                next;
            }

            if ( -l $entry )
            {
                my $linkfile = readlink( $entry );

                #
                #   Broken ?
                #
                if ( ! -e $entry )
                {
                    print "Broken link: $entry ---> $linkfile\n";
                    next;
                }

                #
                #   Allowed to be relative
                #       ie: ../ or someDir
                #
                next unless ( $linkfile =~ m~^/~ );

                #
                #   Allowed to be a link to a file in the same directory
                #
                next unless ( $linkfile =~ m~/~ );

                #
                #   Absolute links are not good
                #
                print "Absolute Link: $entry ---> $linkfile\n";
            }
        }
        scan_dir( @dirs );
    }
}