#!/usr/bin/perl
# -----------------------------------------------------------------------------
# Copyright (c) 2014, Perforce Software, Inc. 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.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 PERFORCE SOFTWARE, INC. 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.
# -----------------------------------------------------------------------------
use strict;
use warnings;
use P4;
use Data::Dumper;
# --- Usage -------------------------------------------------------------------
# triggers:
# filter form-out client "/usr/bin/perl /p4/1/bin/triggers/client_filter.pl
# %user% %formname% %formfile%"
# --- Verbose level -----------------------------------------------------------
# 0 - normal operation
# 1 - debug data
my $verbose = 1;
# --- Server connection details -----------------------------------------------
my %info = ( 'p4port' => 'localhost:1666',
'p4user' => 'pallen',
'p4passwd' => 'hs4cpkl9',
'p4charset' => 'none' );
# --- Globals -----------------------------------------------------------------
our $user = shift; # arg[0]
our $client = shift; # arg[1]
our $formfile = shift; # arg[2]
our $comment;
# Set minimum access level to create a view
our $min_acl = 'open';
# -----------------------------------------------------------------------------
# MAIN Function: client_filter
# Description: Filter client 'View' field based on 'p4 protects'
# -----------------------------------------------------------------------------
## Connect and Fetch client spec
my $p4 = p4_connect( \%info );
my $spec = fetch_client( $formfile );
## Exit if client already exists
if( $spec->{Access} ) {
dprint( 1, "exiting: client exists\n");
exit 0;
}
## update form with new view
$spec->{View} = build_view( $user, to_acl($min_acl) );
my $out = $p4->FormatClient( $spec );
## update tmp spec file
open( FILE, ">", $formfile ) or die $!;
my $notice = <<EOF;
# The view in this client spec has been generated by form-out trigger
# with a minimum permission level of '$min_acl'. Please note that there
# may be duplicate or redundant View that must be removed. For example:
#
# View:
# //depot/proj/MAIN/... //myClient/depot/proj/MAIN/...
# //depot/proj/... //myClient/depot/proj/...
#
EOF
print FILE $notice . $comment . $out;
exit 0;
# -----------------------------------------------------------------------------
# Function name: fetch_client( formfile )
# Description: returns spec and updates global comment
# -----------------------------------------------------------------------------
sub fetch_client {
my $file = shift;
my $in_str;
## Grab client spec
open( IN, "<", $file ) or die $!;
while (<IN>) {
## seperate comment from fields
if( $_ =~ /^#.*/ ) {
$comment .= $_;
} else {
$in_str .= $_;
}
}
my $spec = $p4->ParseClient( $in_str );
close( IN );
return $spec;
}
# -----------------------------------------------------------------------------
# Function name: build_view( user, min_acl )
# Description: returns view
# -----------------------------------------------------------------------------
sub build_view {
my $user = shift;
my $min = shift;
## Get users permissions
my @protect = $p4->RunProtects( "-u", $user );
## Build view list of accessible depot paths
my @view;
foreach my $p (@protect) {
## skip exclusion mappings
if( !exists $p->{unmap} ) {
## check acl level
my $perm = $p->{perm};
if( to_acl($perm) >= $min ) {
my $dpath = $p->{depotFile};
dprint( 1, "perm: $dpath ($perm)\n");
## exit, if view for multi depots
if( $dpath =~ /\/\/\.\.\./ ) {
dprint( 1, "exiting: found global protection '//...'\n");
exit 0;
}
## add new view to map
if( $dpath =~ /\/\/(.*)/ ) {
my $cpath = $1;
my $v = "$dpath //$client/$cpath";
push( @view, $v );
dprint( 1, "view: $v\n");
}
}
}
}
## Remove identical lines
@view = uniq( @view );
return \@view;
}
# -----------------------------------------------------------------------------
# Function name: uniq( views )
# Description: return unique list of views
# -----------------------------------------------------------------------------
sub uniq {
return keys %{{ map { $_ => 1 } @_ }};
}
# -----------------------------------------------------------------------------
# Function name: to_acl( string )
# Description: return integer value for cal
# -----------------------------------------------------------------------------
sub to_acl {
my $perm = shift;
my %acl = ( 'list' => 1,
'read' => 2,
'open' => 3,
'write' => 4,
'branch' => 5,
'admin' => 6,
'super' => 7 );
## remove '=' from perm
$perm =~ s/=//;
my $val = $acl{ $perm };
dprint( 2, "to_acl: $perm => $val\n" );
return $val;
}
# -----------------------------------------------------------------------------
# Function name: p4_connect( info )
# Description: Connection helper, takes info as hash
# -----------------------------------------------------------------------------
sub p4_connect {
my $info = shift;
my $p4 = new P4;
$p4->Debug($verbose);
$p4->SetPort( $info->{'p4port'} );
$p4->SetUser( $info->{'p4user'} );
$p4->SetPassword( $info->{'p4passwd'} );
if( $info->{'p4charset'} ne 'none' ) {
$p4->SetCharset( $info->{'p4charset'} );
}
$p4->Connect() or die("Failed to connect to Server " . $info->{'p4port'} );
dprint( 1, "Connected to Server: " . $p4->GetPort() . "\n" );
$p4->RunLogin();
return $p4;
}
# -----------------------------------------------------------------------------
# Function name: dprint( level, 'string' )
# Description: Print out debug messages at verbose level
# -----------------------------------------------------------------------------
sub dprint
{
my $level = shift;
my $pad = "... ";
$pad x= $level;
my $str = shift;
if( $verbose >= $level ) {
print( $pad . $str );
}
}