view release on metacpan or  search on metacpan

bin/slaughter  view on Meta::CPAN

=begin doc

Create a lockfile, which will be removed on process-termination.

=end doc

=cut

sub createLock
{

    #
    #  Get the lockfile - if we failed to define one then abort.
    #
    my $lockfile = $CONFIG{ 'lockfile' };
    return unless ($lockfile);


    #
    # Open the lock-file exclusively.
    #
    open( LOCK, ">>", $lockfile ) or
      die "Failed to open lockfile at $lockfile - $!";

    #
    # Lock the file.
    #
    flock( LOCK, LOCK_EX | LOCK_NB ) or
      die "$0 already running - Lock file $lockfile is locked";


    #
    # The file will be closed when slaughter terminates so although it
    # looks like we're leaking a handle here this is intentional.
    #

}

=begin doc

Create a temporary directory for holding files, some transports need this.

B<NOTE>:  This directory will be removed when this process terminates unless
slaughter was invoked with --no-delete.

=end doc

=cut

sub createTransportDir
{

    #
    #  Temporary directory for transports to use
    #
    $CONFIG{ 'transportDir' } = tempdir( CLEANUP => !$CONFIG{ 'nodelete' } );

    #  The temporary directory should not be world-readable
    chmod 0700, $CONFIG{ 'transportDir' };
}



=begin doc

Test the environment - which is a combination of the command line flags, and
configuration file settings, and the local user.

=end doc

=cut

sub testEnvironment
{
    if ( $UID != 0 and !$CONFIG{ 'allownonroot' } )
    {
        print <<EOF;
You must launch this command as root.
EOF
        exit 1;
    }

    #
    #  If we have no transport type, but we do have a prefix, we can attempt
    # to infer what to use.
    #
    if ( $CONFIG{ 'prefix' } && !$CONFIG{ 'transport' } )
    {

        # show what is going on
        $CONFIG{ 'verbose' } &&
          print "Attempting to guesss transport for $CONFIG{'prefix'}\n";

        # git://.... or   http://.../foo.git
        $CONFIG{ 'transport' } = "git"
          if ( $CONFIG{ 'prefix' } =~ /(^git|\.git$)/i );

        # http://.../foo.hg
        $CONFIG{ 'transport' } = "hg" if ( $CONFIG{ 'prefix' } =~ /\.hg$/i );

        # rsync://.../
        $CONFIG{ 'transport' } = "rsync"
          if ( $CONFIG{ 'prefix' } =~ /^rsync/i );

        # Local policies will start with /
        $CONFIG{ 'transport' } = "local"
          if ( $CONFIG{ 'prefix' } =~ /^\// );

        # fall-back to HTTP.
        $CONFIG{ 'transport' } = "http" if ( !$CONFIG{ 'transport' } );

        $CONFIG{ 'verbose' } &&
          print "Guessed transport: $CONFIG{'transport'}\n";
    }

    #
    # Abort if we don't have both transport & prefix set now.
    #
    if ( !$CONFIG{ 'transport' } || !$CONFIG{ 'prefix' } )

bin/slaughter  view on Meta::CPAN

            #  Get the initial value.
            my $include = $2;

            #  Strip the trailing ";".
            $include =~ s/;$//g;

            # Strip leading/trailing stuff.
            $include =~ s/^([("' \t]+)|(['" \t)]+)$//g;

            my $tmp =
              $object->fetchContents( prefix => "/modules/",
                                      file   => $include );
            if ($tmp)
            {
                $modules .= "\n{\n" . "\n# Module inclusion - $include\n";
                $modules .= $tmp . "}\n";
                $line = "";
            }
            else
            {
                $modules .= "\n# Module inclusion failed - $include\n";
                $line = "";
            }
        }

        $policy .= $line;
        $policy .= "\n";
    }

    return ( $policy, $modules );
}




=begin doc

Write out specified policy content into a form which can be executed,
and return the name of the file to which it was written.

Once complete this is the script which will be executed on the client
system - so it will be valid perl.

=end doc

=cut

sub writeoutPolicy
{
    my ( $policy, $modules ) = (@_);


    #
    # Create the temporary file, and set the permissions on
    # it to something restrictive.
    #
    my ( undef, $name ) = File::Temp::tempfile();
    $name = $CONFIG{ 'outfile' } if $CONFIG{ 'outfile' };
    if ( $^O ne "MSWin32" )
    {
        chmod( 0700, $name );
    }

    #
    #  The user might have specified an include-file to be added
    # to the wrapper.  Here we load that, if present.
    #
    my $include = "";
    if ( $CONFIG{ 'include' } && ( -e $CONFIG{ 'include' } ) )
    {
        open( my $inc, "<", $CONFIG{ 'include' } );
        while ( my $line = <$inc> )
        {
            $include .= $line;
        }
        close($inc);
    }

    #
    #  Two lines we output into the generated script.
    #
    my $line = "our \%template = (";
    my $keys = "";

    #
    #  Generate the fixed sections we output,
    # which are based upon our global config.
    #
    foreach my $key ( sort keys %CONFIG )
    {
        my $val = $CONFIG{ $key };

        if ( defined($val) )
        {
            $keys .= "our \$$key = '$val';\n";
            $line .= "\n\t$key => '$val',";
        }
        else
        {
            $keys .= "our \$$key = undef;\n";
            $line .= "\n\t$key => undef,";
        }

    }

    $line =~ s/, $//g;
    $line .= "\t);\n";

    #
    #  Open the file for writing.
    #
    open my $handle, ">", $name or
      die "Failed to write to file : $!";


    #
    #  Write the script.
    #
    print $handle <<EOF;
#!/usr/bin/perl -w