view release on metacpan or  search on metacpan

lib/Net/MitDK.pm  view on Meta::CPAN

}

sub create
{
	my ($self, $profile, %opt) = @_;
	my $file = $self->homepath . "/$profile.profile";

	if ( -f $file ) {
		return 2 if $opt{ok_if_exists};
		return (undef, "Profile exists already");
	}

	return $self->save($profile, $opt{payload} // {} );
}

sub lock
{
	my $f = shift;
	return 1 if flock( $f, LOCK_NB | LOCK_EX);
	sleep(1);
	return 1 if flock( $f, LOCK_NB | LOCK_EX);
	sleep(1);
	return      flock( $f, LOCK_NB | LOCK_EX);
}

sub load
{
	my ($self, $profile ) = @_;
	my $file = $self->homepath . "/$profile.profile";

	return (undef, "No such profile") unless -f $file;
	local $/;
	open my $f, "<", $file or return (0, "Cannot open $file:$!");
	return (undef, "Cannot acquire lock on $file") unless lock($f);

	my $r = <$f>;
	close $f;

	my $json;
	eval { $json = decode_json($r) };
	return (undef, "Corrupted profile $file: $@") unless $json;

	$self->{timestamps}->{$profile} = time;

	return $json;
}

sub save
{
	my ($self, $profile, $hash) = @_;

	return (undef, "$profile is readonly") if $self->readonly;

	my $home = $self->homepath;
	unless ( -d $home ) {
		mkdir $home or return (undef, "Cannot create $home: $!");
		return (undef, "cannot chmod 0750 $home:$!") unless chmod 0750, $home;
		if ( $^O !~ /win32/i) {
			my (undef,undef,$gid) = getgrnam('nobody');
			return (undef, "no group `nobody`") unless defined $gid;
			return (undef, "cannot chown user:nobody $home:$!") unless chown $>, $gid, $home;
		}
	}

	my $json;
	my $encoder = JSON::XS->new->ascii->pretty;
	eval { $json = $encoder->encode($hash) };
	return (undef, "Cannot serialize profile: $!") if $@;

	my $file = "$home/$profile.profile";
	my $f;
	if ( -f $file ) {
		open $f, "+<", $file or return (undef, "Cannot create $file:$!");
		return (undef, "Cannot acquire lock on $file") unless lock($f);
		seek $f, 0, SEEK_SET;
		truncate $f, 0 or return (undef, "Cannot save $file:$!");
	} else {
		open $f, ">", $file or return (undef, "Cannot create $file:$!");
	}
	print $f $json or return (undef, "Cannot save $file:$!");
	close $f or return (undef, "Cannot save $file:$!");

	if ( $^O !~ /win32/i) {
		return (undef, "cannot chmod 0640 $file:$!") unless chmod 0640, $file;
		my (undef,undef,$gid) = getgrnam('nobody');
		return (undef, "no group `nobody`") unless defined $gid;
		return (undef, "cannot chown user:nobody $file:$!") unless chown $>, $gid, $file;
	}

	$self->{timestamps}->{$profile} = time;

	return 1;
}

sub remove
{
	my ($self, $profile) = @_;
	unlink $self->homepath . "/$profile.profile" or return (undef, "Cannot remove $profile:$!");
	return 1;
}

sub refresh_needed
{
	my ( $self, $profile ) = @_;
	return 0 unless exists $self->{timestamps}->{$profile};

	my $file = $self->homepath . "/$profile.profile";
	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($file);
	return 0 unless defined $mtime;

	return $mtime > $self->{timestamps}->{$profile};
}

1;

=pod

=head1 NAME

Net::MitDK - perl API for http://mit.dk/

=head1 DESCRIPTION

Read-only interface for MitDK. See README for more info.

=head1 AUTHOR

Dmitry Karasik <dmitry@karasik.eu.org>

=cut