Lchown
view release on metacpan or search on metacpan
use strict;
use warnings;
use Module::Build;
my $builder = Module::Build->new(
module_name => 'Lchown',
dist_author => 'Nick Cleaton <nick@cleaton.net>',
all_from => 'lib/Lchown.pm',
license => 'perl',
build_requires => {
'ExtUtils::CBuilder' => 0,
'Test::More' => 0,
},
add_to_cleanup => [ 'Lchown-*' ],
create_makefile_pl => 'small',
);
$builder->create_build_script();
Revision history for Perl extension Lchown.
1.01 2009-10-18
RT #25968
changed to Module::Build
1.00 Nov 13 2004
now works on perls back to 5.00404
minor code tidy
added pod tests
Build.PL
Changes
lib/Lchown.pm
lib/Lchown.xs
MANIFEST This list of files
MANIFEST.SKIP
README
t/allplatforms.t
t/noimport.t
t/notsup.t
t/pod-coverage.t
t/pod.t
t/sup.t
Makefile.PL
MANIFEST.SKIP view on Meta::CPAN
# Avoid Module::Build generated and utility files.
\bBuild$
\bBuild.bat$
\b_build
\bBuild.COM$
\bBUILD.COM$
\bbuild.com$
# Avoid archives of this distribution
\bLchown-[\d\.\_]+
---
name: Lchown
version: 1.01
author:
- 'Nick Cleaton <nick@cleaton.net>'
abstract: use the lchown(2) system call from Perl
license: perl
resources:
license: http://dev.perl.org/licenses/
build_requires:
ExtUtils::CBuilder: 0
Test::More: 0
configure_requires:
Module::Build: 0.35
provides:
Lchown:
file: lib/Lchown.pm
version: 1.01
generated_by: Module::Build version 0.35
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
Lchown - perl interface to the lchown(2) system call
The Lchown module provides a perl interface to the lchown(2) UNIX system
call, on systems that support lchown. The lchown(2) call is used to
change the ownership and group of symbolic links.
DEPENDENCIES
The test suite requires the Test::More module, available from CPAN.
The oldest perl version that I've tested against is 5.00404.
INSTALLATION
perl Build.PL
./Build
./Build test
./Build install
This module should build and pass tests on systems without the lchown
system call. Any lchown call will fail at runtime on such systems.
Since the lchown system call often requires root privileges to make any
change, most of the tests will be skipped unless "make test" is run as
root.
Copyright 2003-2009 Nick Cleaton, all rights reserved.
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
lib/Lchown.pm view on Meta::CPAN
package Lchown;
use strict;
use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(lchown);
@EXPORT_OK = qw(lchown LCHOWN_AVAILABLE);
$VERSION = '1.01';
require XSLoader;
XSLoader::load('Lchown', $VERSION);
sub LCHOWN_AVAILABLE () {
defined lchown(0,0) ? 1 : 0;
}
1;
__END__
=head1 NAME
Lchown - use the lchown(2) system call from Perl
=head1 SYNOPSIS
use Lchown;
lchown $uid, $gid, 'foo' or die "lchown: $!";
my $count = lchown $uid, $gid, @filenames;
# or
use Lchown qw(lchown LCHOWN_AVAILABLE);
warn "this system lacks the lchown system call\n" unless LCHOWN_AVAILABLE;
...
# or
use Lchown ();
warn "this won't work\n" unless Lchown::LCHOWN_AVAILABLE;
Lchown::lchown $uid, $gid, 'foo' or die "lchown: $!";
=head1 DESCRIPTION
Provides a perl interface to the C<lchown()> system call, on platforms that
support it.
=head1 DEFAULT EXPORTS
The following symbols are exported be default:
=over
=item lchown (LIST)
Like the C<chown> builtin, but using the C<lchown()> system call so that
symlinks will not be followed. Returns the number of files successfully
changed.
On systems without the C<lchown()> system call, C<lchown> always returns
C<undef> and sets C<errno> to C<ENOSYS> (Function not implemented).
=back
=head1 ADDITIONAL EXPORTS
The following symbols are available for export but are not exported by
default:
=over
=item LCHOWN_AVAILABLE ()
Returns true on platforms with the C<lchown()> system call, and false on
platforms without.
=back
=head1 SEE ALSO
L<perlfunc/chown>, L<lchown(2)>
=head1 AUTHOR
Nick Cleaton E<lt>nick@cleaton.netE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2003-2009 Nick Cleaton, all rights reserved.
This program is free software; you can redistribute it and/or modify it under
lib/Lchown.xs view on Meta::CPAN
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
MODULE = Lchown PACKAGE = Lchown
PROTOTYPES: ENABLE
SV *
lchown(owner, group, ...)
unsigned owner
unsigned group
PROTOTYPE: @
PREINIT:
int i;
int ok;
STRLEN len;
CODE:
#ifdef HAS_LCHOWN
ok = 0;
for ( i=2 ; i<items ; i++ )
if ( lchown((char *)SvPV(ST(i),len), owner, group) == 0 )
ok++;
ST(0) = sv_2mortal(newSViv(ok));
#else
errno = ENOSYS;
ST(0) = &PL_sv_undef;
#endif
t/allplatforms.t view on Meta::CPAN
use strict;
use warnings;
use Test::More (tests => 2);
BEGIN { use_ok('Lchown') }
ok( !lchown(9,9,"nosuchfile"), "failed on nonexistent file" );
t/noimport.t view on Meta::CPAN
use strict;
use warnings;
use Test::More (tests => 3);
use Lchown ();
SKIP: {
skip "this system lacks lchown", 3 unless Lchown::LCHOWN_AVAILABLE;
skip "not running as root", 3 if $>;
symlink 'bar', 'foo' or die "symlink: $!";
my $result = Lchown::lchown 123, 456, 'foo';
is( $result, 1, "Lchown::Lchown prototype works" );
my ($uid,$gid) = (lstat 'foo')[4,5];
is( $uid, 123, "Lchown::lchown foo set uid 123" );
is( $gid, 456, "Lchown::lchown foo set gid 456" );
unlink 'foo' or die "unlink: $!";
}
use strict;
use warnings;
use Test::More (tests => 6);
use Lchown qw(lchown LCHOWN_AVAILABLE);
SKIP: {
skip "this system has lchown", 6 if LCHOWN_AVAILABLE;
my $uid = $>;
my $gid = $) =~ /^(\d+)/;
ok( ! defined lchown($uid, $gid), "null lchown call failed" );
like( $!, '/function not implemented/i', "null lchown gave ENOSYS" );
my $symlink_exists = eval { symlink("",""); 1 };
skip "Symlink not supported", 4 if !defined($symlink_exists);
symlink 'bar', 'foo' or skip "can't make a symlink", 2;
ok( ! defined lchown($uid, $gid, 'foo'), "valid lchown call failed" );
like( $!, '/function not implemented/i', "valid lchown gave ENOSYS" );
unlink 'foo';
ok( ! defined lchown($uid, $gid, 'nosuchfile'), "missing file lchown call failed" );
like( $!, '/function not implemented/i', "file valid lchown gave ENOSYS" );
}
use strict;
use warnings;
use Test::More (tests => 17);
use Lchown qw(lchown LCHOWN_AVAILABLE);
SKIP: {
skip "this system lacks lchown", 17 unless LCHOWN_AVAILABLE;
is( lchown(0,0), 0, "null lchown gave 0" );
my $result = lchown 0, 0;
is( $result, 0, "null lchown without parens" );
is( lchown(0,0,'nosuchfile','nosuchfile.bak'), 0,
"lchown returns 0 with 2 missing files");
skip "not running as root", 14 if $>;
symlink 'bar', 'foo' or die "symlink: $!";
is( lchown(123,456,'foo'), 1, "lchown foo success" );
my ($uid,$gid) = (lstat 'foo')[4,5];
is( $uid, 123, "lchown foo set uid 123" );
is( $gid, 456, "lchown foo set gid 456" );
unlink 'foo' or die "unlink: $!";
symlink 'bar', 'foo' or die "symlink: $!";
symlink 'bar', 'baz' or die "symlink: $!";
is( lchown(123,456,'foo','baz'), 2, "foo,baz success" );
($uid,$gid) = (lstat 'foo')[4,5];
is( $uid, 123, "foo,baz set foo uid 123" );
is( $gid, 456, "foo,baz set foo gid 456" );
($uid,$gid) = (lstat 'baz')[4,5];
is( $uid, 123, "foo,baz set baz uid 123" );
is( $gid, 456, "foo,baz set baz gid 456" );
unlink 'foo' or die "unlink: $!";
unlink 'baz' or die "unlink: $!";
symlink 'bar', 'foo' or die "symlink: $!";
is( lchown(123,456,'foo','nosuch'), 1, "foo,nosuch success for foo" );
($uid,$gid) = (lstat 'foo')[4,5];
is( $uid, 123, "foo,nosuch set foo uid 123" );
is( $gid, 456, "foo,nosuch set foo gid 456" );
unlink 'foo' or die "unlink: $!";
symlink 'bar', 'foo' or die "symlink: $!";
is( lchown(123,456,'nosuch','foo'), 1, "nosuch,foo success for foo" );
($uid,$gid) = (lstat 'foo')[4,5];
is( $uid, 123, "nosuch,foo set foo uid 123" );
is( $gid, 456, "nosuch,foo set foo gid 456" );
unlink 'foo' or die "unlink: $!";
}
( run in 1.384 second using v1.01-cache-2.11-cpan-5511b514fd6 )