view release on metacpan or  search on metacpan

lib/IPC/LockTicket.pm  view on Meta::CPAN

	if ( $objSelf->{_uriPath}
	&& -s $objSelf->{_uriPath}
	&& open(my $fh, '<', $objSelf->{_uriPath}) ) {
		flock($fh, 2);

		# Test if file is readable
		try {
			retrieve($objSelf->{_uriPath})
			}
		catch ($strError) {
			$strErrors	.= qq{"$objSelf->{_uriPath}": Mailformed shared memory file.\n$strError\n};
			}

		close($fh) or $strErrors .= qq{$strCaller(): Unable to close "$objSelf->{_uriPath}" properly\n};
		}
	# User failure
	elsif ( ! $objSelf->{_uriPath} ) {
		$strErrors		.= qq{$strCaller(): Missing argument!\n};
		}
	# If open() failes
	elsif ( -s $objSelf->{_uriPath} ) {
		$strErrors		.= qq{$strCaller(): Unable to open "$objSelf->{_uriPath}"!\n};
		}

	# Some more fine tuning
	if ( $objSelf->{_uriPath}
	&& -d $objSelf->{_uriPath} ) {
		$strErrors	.= qq{"$objSelf->{_uriPath}": A folder can't be a share memory file!\n};
		}
	if ( $objSelf->{_uriPath} !~ m{$rxpFullPath} ) {
		$strErrors	.= qq{"$objSelf->{_uriPath}": is an inadequate path or name!\n};
		}

	# Protect file if not set other wise
	if ( defined($objSelf->{_octPermission})
	&& length(qq{$objSelf->{_octPermission}}) > 4 ) {
		$strErrors	.= sprintf(qq{"%04o": Invalid permission. Must be a octal number of four or NULL.\n}, $objSelf->{_octPermission});
		}
	elsif ( ! defined($objSelf->{_octPermission}) ) {
		$objSelf->{_octPermission}	= 0600;
		}

	# Check permissions
	if ( -e $objSelf->{_uriPath}
	&& ! -r $objSelf->{_uriPath} ) {
		$strErrors	.= qq{"$objSelf->{_uriPath}": No read permission.\n};
		}
	if ( -e $objSelf->{_uriPath}
	&& ! -w $objSelf->{_uriPath} ) {
		$strErrors	.= qq{"$objSelf->{_uriPath}": No write permission.\n};
		}

	# What if permissions differ??
	if ( -e $objSelf->{_uriPath} ) {
		my %mxdFileStat		= ();
		my @strParts		= qw(o g u ts);
		my %intFilePerms	= ();	# user:users 0600
		my @intFileGrpsMbrs	= ();
		my %intObjPerms		= ();	# root:root 0600
		my $strEUName		= (getpwuid($EUID))[0];
		my @intObjGrps		= ( (getpwuid($EUID))[3] );
		my $cntPosition		= 0;
		@mxdFileStat{qw(dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks)} =
			stat($objSelf->{_uriPath});
		%intFilePerms		=
			map { $strParts[$cntPosition++] => $_ } #( $_ % 2 ) ? $_ - 1 : $_ }		# Execution bit is not required
			reverse(split('', sprintf(q{%04o}, $mxdFileStat{mode} & 07777)));
		$cntPosition		= 0;
		%intObjPerms		=
			map { $strParts[$cntPosition++] => $_ } #( $_ % 2 ) ? $_ - 1 : $_ }		# Execution bit is not required
			reverse(split('', sprintf(q{%04o}, $objSelf->{_octPermission})));
		@intFileGrpsMbrs	=		# Group's members
			map { (getpwnam($_))[2] }	# UID
			grep { defined && $_ ne '' }
			split(m{$rxpWhitespaces}, (getgrgid($mxdFileStat{gid}))[3]);
		push(@intFileGrpsMbrs, 0);	# Root is part of any group

		# If file owner's group is same as the file's group we need to add the user's name to the File Group Members list, in case it's the user's main group, which won't be shown by getent groups
		while ( my(undef, undef, $intUID, $intGID) = getpwent() ) {

			# Users' default groups
			if ( $intGID == $mxdFileStat{gid} ) {	
				push(@intFileGrpsMbrs, $intUID);
				}
			}

		while ( my(undef, undef, $intGID, $strMembers) = getgrent() ) {

			# We need to know all real groups
			if ( grep { $strEUName eq $_ } split(m{$rxpWhitespaces}, $strMembers) ) {
				push(@intObjGrps, $intGID);
				}
			}

		if ( $intFilePerms{o} > $intObjPerms{o}	# General rights are to high
		|| $intFilePerms{g} > $intObjPerms{g}		# General rights are to high

		# File is not owned by user's real groups
		||( !( grep { $mxdFileStat{gid} == $_ } @intObjGrps )
		&& $intFilePerms{g} > $intObjPerms{o} )	# Foreign group has more rights as wanted for other users


		# File is not owned effective user
		||($mxdFileStat{uid} != $EUID
		&& (

		## File owner is part of file owning group -> access can happen through group
		#(grep { $mxdFileStat{uid} == $_ } @intFileGrpsMbrs	
		#&& $intFilePerms{g} > $intObjPerms{o} )
		#
		## File owner is not part of file owning group -> access happens only through owner
		#||( !( grep { $mxdFileStat{uid} == $_ } @intFileGrpsMbrs )
		( !( grep { $mxdFileStat{uid} == $_ } @intFileGrpsMbrs )
		&& $intFilePerms{u} > $intObjPerms{o} )

		) ) ) {
			$strErrors	.= qq{Existing file "$objSelf->{_uriPath}" has douptful permissions.\n};

			}
		}