init

wcmtools/ddlockd/api/perl/DDLockClient.pm

@@ -0,0 +1,363 @@
+#!/usr/bin/perl
+###########################################################################
+
+=head1 NAME
+
+DDLockClient - Client library for distributed lock daemon
+
+=head1 SYNOPSIS
+
+  use DDLockClient ();
+
+  my $cl = new DDLockClient (
+	servers => ['locks.localnet:7004', 'locks2.localnet:7002', 'localhost']
+  );
+
+  # Do something that requires locking
+  if ( my $lock = $cl->trylock("foo") ) {
+    ...do some 'foo'-synchronized stuff...
+  } else {
+    die "Failed to lock 'foo': $!";
+  }
+
+  # You can either just let $lock go out of scope or explicitly release it:
+  $lock->release;
+
+=head1 DESCRIPTION
+
+This is a client library for ddlockd, a distributed lock daemon not entirely
+unlike a very simplified version of the CPAN module IPC::Locker.
+
+=head1 REQUIRES
+
+L<Socket>
+
+=head1 EXPORTS
+
+Nothing.
+
+=head1 AUTHOR
+
+Brad Fitzpatrick <brad@danga.com>
+
+Copyright (c) 2004 Danga Interactive, Inc.
+
+=cut
+
+###########################################################################
+
+#####################################################################
+###	D D L O C K   C L A S S
+#####################################################################
+package DDLock;
+
+BEGIN {
+    use Socket qw{:DEFAULT :crlf};
+    use IO::Socket::INET ();
+
+    use constant DEFAULT_PORT => 7002;
+
+    use fields qw( name sockets pid );
+}
+
+
+
+### (CONSTRUCTOR) METHOD: new( $name, @sockets )
+### Create a new lock object that corresponds to the specified I<name> and is
+### held by the given I<sockets>.
+sub new {
+    my DDLock $self = shift;
+    $self = fields::new( $self ) unless ref $self;
+
+    $self->{pid} = $$;
+    $self->{name} = shift;
+    $self->{sockets} = $self->getlocks( $self->{name}, @_ );
+
+    return $self;
+}
+
+
+### (PROTECTED) METHOD: getlocks( $lockname, @servers )
+### Try to obtain locks with the specified I<lockname> from one or more of the
+### given I<servers>.
+sub getlocks {
+    my DDLock $self = shift;
+    my $lockname = shift;
+    my @servers = @_;
+
+    my (
+        @sockets,
+        $sock,
+        $res,
+       );
+
+    # First create connected sockets to all the lock hosts
+    @sockets = ();
+  SERVER: foreach my $server ( @servers ) {
+        my ( $host, $port ) = split /:/, $server;
+        $port ||= DEFAULT_PORT;
+
+        my $sock = new IO::Socket::INET (
+            PeerAddr    => $host,
+            PeerPort    => $port,
+            Proto       => "tcp",
+            Type        => SOCK_STREAM,
+            ReuseAddr   => 1,
+            Blocking    => 1,
+           ) or next SERVER;
+
+        $sock->printf( "trylock lock=%s%s", eurl($lockname), CRLF );
+        chomp( $res = <$sock> );
+        die "$server: '$lockname' $res\n" unless $res =~ m{^ok\b}i;
+
+        push @sockets, $sock;
+    }
+
+    die "No available lock hosts" unless @sockets;
+    return \@sockets;
+}
+
+
+### METHOD: release()
+### Release the lock held by the lock object. Returns the number of sockets that
+### were released on success, and dies with an error on failure.
+sub release {
+    my DDLock $self = shift;
+
+    my (
+        $count,
+        $res,
+        $sock,
+       );
+
+    # lock server might have gone away, but we don't really care.
+    local $SIG{'PIPE'} = "IGNORE";
+
+    $count = 0;
+    while (( $sock = shift @{$self->{sockets}} )) {
+        $sock->printf( "releaselock lock=%s%s", eurl($self->{name}), CRLF );
+        chomp( $res = <$sock> );
+
+        if ( $res && $res !~ m{^ok\b}i ) {
+            my $port = $sock->peerport;
+            my $addr = $sock->peerhost;
+            die "releaselock ($addr): $res\n";
+        }
+
+        $count++;
+    }
+
+    return $count;
+}
+
+
+### FUNCTION: eurl( $arg )
+### URL-encode the given I<arg> and return it.
+sub eurl
+{
+    my $a = $_[0];
+    $a =~ s/([^a-zA-Z0-9_,.\\: -])/uc sprintf("%%%02x",ord($1))/eg;
+    $a =~ tr/ /+/;
+    return $a;
+}
+
+
+
+#####################################################################
+###	D D F I L E L O C K   C L A S S
+#####################################################################
+package DDFileLock;
+
+BEGIN {
+    use Fcntl qw{:DEFAULT :flock};
+    use File::Spec qw{};
+    use File::Path qw{mkpath};
+    use IO::File qw{};
+
+    use fields qw{name path tmpfile pid};
+}
+
+
+our $TmpDir = File::Spec->tmpdir;
+
+### (CONSTRUCTOR) METHOD: new( $lockname )
+### Createa a new file-based lock with the specified I<lockname>.
+sub new {
+    my DDFileLock $self = shift;
+    $self = fields::new( $self ) unless ref $self;
+    my ( $name, $lockdir ) = @_;
+
+    $self->{pid} = $$;
+
+    $lockdir ||= $TmpDir;
+    if ( ! -d $lockdir ) {
+        # Croaks if it fails, so no need for error-checking
+        mkpath $lockdir;
+    }
+
+    my $lockfile = File::Spec->catfile( $lockdir, eurl($name) );
+
+    # First open a temp file
+    my $tmpfile = "$lockfile.$$.tmp";
+    if ( -e $tmpfile ) {
+        unlink $tmpfile or die "unlink: $tmpfile: $!";
+    }
+
+    my $fh = new IO::File $tmpfile, O_WRONLY|O_CREAT|O_EXCL
+        or die "open: $tmpfile: $!";
+    $fh->close;
+    undef $fh;
+
+    # Now try to make a hard link to it
+    link( $tmpfile, $lockfile )
+        or die "link: $tmpfile -> $lockfile: $!";
+    unlink $tmpfile or die "unlink: $tempfile: $!";
+
+    $self->{path} = $lockfile;
+    $self->{tmpfile} = $tmpfile;
+
+    return $self;
+}
+
+
+### METHOD: release()
+### Release the lock held by the object.
+sub release {
+    my DDFileLock $self = shift;
+    return unless $self->{path};
+    unlink $self->{path} or die "unlink: $self->{path}: $!";
+    unlink $self->{tmpfile};
+}
+
+
+### FUNCTION: eurl( $arg )
+### URL-encode the given I<arg> and return it.
+sub eurl
+{
+    my $a = $_[0];
+    $a =~ s/([^a-zA-Z0-9_,.\\: -])/sprintf("%%%02X",ord($1))/eg;
+    $a =~ tr/ /+/;
+    return $a;
+}
+
+
+DESTROY {
+    my $self = shift;
+    $self->release if $$ == $self->{pid};
+}
+
+
+#####################################################################
+###	D D L O C K C L I E N T   C L A S S
+#####################################################################
+package DDLockClient;
+use strict;
+
+BEGIN {
+    use fields qw( servers lockdir );
+    use vars qw{$Error};
+}
+
+$Error = undef;
+
+our $Debug = 0;
+
+
+### (CLASS) METHOD: DebugLevel( $level )
+sub DebugLevel {
+    my $class = shift;
+
+    if ( @_ ) {
+        $Debug = shift;
+        if ( $Debug ) {
+            *DebugMsg = *RealDebugMsg;
+        } else {
+            *DebugMsg = sub {};
+        }
+    }
+
+    return $Debug;
+}
+
+
+sub DebugMsg {}
+
+
+### (CLASS) METHOD: DebugMsg( $level, $format, @args )
+### Output a debugging messages formed sprintf-style with I<format> and I<args>
+### if I<level> is greater than or equal to the current debugging level.
+sub RealDebugMsg {
+    my ( $class, $level, $fmt, @args ) = @_;
+    return unless $Debug >= $level;
+
+    chomp $fmt;
+    printf STDERR ">>> $fmt\n", @args;
+}
+
+
+### (CONSTRUCTOR) METHOD: new( %args )
+### Create a new DDLockClient 
+sub new {
+    my DDLockClient $self = shift;
+    my %args = @_;
+
+    $self = fields::new( $self ) unless ref $self;
+    die "Servers argument must be an arrayref if specified"
+        unless !exists $args{servers} || ref $args{servers} eq 'ARRAY';
+    $self->{servers} = $args{servers} || [];
+    $self->{lockdir} = $args{lockdir} || '';
+
+    return $self;
+}
+
+
+### METHOD: trylock( $name )
+### Try to get a lock from the lock daemons with the specified I<name>. Returns
+### a DDLock object on success, and undef on failure.
+sub trylock {
+    my DDLockClient $self = shift;
+    my $lockname = shift;
+
+    my $lock;
+
+    # If there are servers to connect to, use a network lock
+    if ( @{$self->{servers}} ) {
+        $self->DebugMsg( 2, "Creating a new DDLock object." );
+        $lock = eval { DDLock->new($lockname, @{$self->{servers}}) };
+    }
+
+    # Otherwise use a file lock
+    else {
+        $self->DebugMsg( 2, "No servers configured: Creating a new DDFileLock object." );
+        $lock = eval { DDFileLock->new($lockname, $self->{lockdir}) };
+    }
+
+    # If no lock was acquired, fail and put the reason in $Error.
+    unless ( $lock ) {
+        return $self->lock_fail( $@ ) if $@;
+        return $self->lock_fail( "Unknown failure." );
+    }
+
+    return $lock;
+}
+
+
+### (PROTECTED) METHOD: lock_fail( $msg )
+### Set C<$!> to the specified message and return undef.
+sub lock_fail {
+    my DDLockClient $self = shift;
+    my $msg = shift;
+
+    $Error = $msg;
+    return undef;
+}
+
+
+1;
+
+
+# Local Variables:
+# mode: perl
+# c-basic-indent: 4
+# indent-tabs-mode: nil
+# End:

wcmtools/ddlockd/api/perl/MANIFEST

@@ -0,0 +1,5 @@
+DDLockClient.pm
+Makefile.PL
+MANIFEST
+t/00_require.t
+testlock.pl

wcmtools/ddlockd/api/perl/MANIFEST.SKIP

@@ -0,0 +1,11 @@
+^#
+\bCVS\b
+^MANIFEST\.
+^Makefile$
+~$
+\.html$
+\.old$
+^blib/
+_blib$
+^MakeMaker-\d
+^\.exists

wcmtools/ddlockd/api/perl/Makefile.PL

@@ -0,0 +1,33 @@
+#!/usr/bin/perl
+#
+#	Perl Makefile for DDLockClient/DDLock
+#	$Id: Makefile.PL,v 1.2 2004/05/27 22:08:51 deveiant Exp $
+#
+#	Invoke with 'perl Makefile.PL'
+#
+#	See ExtUtils::MakeMaker (3) for more information on how to influence
+#	 the contents of the Makefile that is written
+#
+
+use ExtUtils::MakeMaker;
+my $version = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+my %config = (
+	NAME			=> 'DDLockClient',
+	VERSION			=> "0." . $version,
+	AUTHOR			=> 'Brad Fitzpatrick <brad@danga.com>',
+	ABSTRACT		=> 'A lock client for the distributed lock daemon ddlockd',
+	PREREQ_PM		=> {
+		Socket	=> 0,
+	},
+	dist			=> {
+		CI				=> "cvs commit",
+		RCS_LABEL		=> 'cvs tag r$(VERSION_SYM)',
+		SUFFIX			=> ".bz2",
+		DIST_DEFAULT	=> 'all tardist',
+		COMPRESS		=> "bzip2",
+	},
+   );
+
+
+WriteMakefile( %config );

wcmtools/ddlockd/api/perl/stresslock.pl

@@ -0,0 +1,57 @@
+#!/usr/bin/perl -w
+
+use Fcntl;
+use lib "blib/lib";
+use DDLockClient ();
+use Data::Dumper ();
+
+$Data::Dumper::Terse = 1;
+$Data::Dumper::Indent = 1;
+
+$| = 1;
+
+my $DDServers =  [
+#	'localhost:7003',
+#	'localhost:7004',
+	'localhost:7002',
+   ];
+
+foreach my $servers ( $DDServers, [] ) {
+	print "Creating client (@$servers)...";
+	my $cl = new DDLockClient ( servers => $servers )
+		or die $DDLockClient::Error;
+	print "done:\n";
+
+        for ( my $i = 0; $i < 10; $i++ ) {
+            if ( my $pid = fork ) {
+		print "Created child: $pid\n";
+            } else {
+                for ( my $ct = 0; $ct < 150; $ct++ ) {
+                    my $rand = int(rand(10));
+                    #print "Trying to create lock 'lock$rand' lock in process $$...\n";
+                    if ( my $lock = $cl->trylock("lock$rand") ) {
+                        my $file = ".stressfile-$rand";
+                        my $fh = new IO::File $file, O_WRONLY|O_EXCL|O_CREAT;
+                        die "Couldn't create file $file: $!" unless $fh;
+                        $fh->close;
+                        unlink $file;
+                    }
+                }
+                exit 0;
+            }
+        }
+
+        while ((my $pid = wait) != -1) {
+            if ($? == 0) {
+                print "$pid is done, okay.\n";
+            } else {
+                die "$pid FAILED\n";
+            }
+        }
+
+	print "done.\n\n";
+}
+
+
+
+

wcmtools/ddlockd/api/perl/t/00_require.t

@@ -0,0 +1,12 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test;
+
+BEGIN { plan tests => 3 }
+
+ok( eval { require DDLockClient; 1 } );
+ok( exists $::{"DDLockClient::"} );
+ok( exists $::{"DDLock::"} );
+
+

wcmtools/ddlockd/api/perl/testlock.pl

@@ -0,0 +1,46 @@
+#!/usr/bin/perl -w
+
+use lib "blib/lib";
+use DDLockClient ();
+use Data::Dumper ();
+
+$Data::Dumper::Terse = 1;
+$Data::Dumper::Indent = 1;
+
+$| = 1;
+
+my $DDServers =  [
+	'localhost:7003',
+	'localhost:7004',
+	'localhost',
+   ];
+
+foreach my $servers ( $DDServers, [] ) {
+	print "Creating client...";
+	my $cl = new DDLockClient ( servers => $servers )
+		or die $DDLockClient::Error;
+	print "done:\n";
+
+	print "Creating a 'foo' lock...";
+	my $lock = $cl->trylock( "foo" )
+		or print "Error: $DDLockClient::Error\n";
+	print "done.\n";
+
+	if ( my $pid = fork ) {
+		waitpid( $pid, 0 );
+	} else {
+		print "Trying to create a 'foo' lock in process $$...";
+		my $lock2 = $cl->trylock( "foo" )
+			or print "Error: $DDLockClient::Error\n";
+		print "done:\n";
+		exit;
+	}
+
+	print "Releasing the 'foo' lock...";
+	$lock->release or die;
+	print "done.\n\n";
+}
+
+
+
+

wcmtools/ddlockd/server/ddlockd

@@ -0,0 +1,316 @@
+#!/usr/bin/perl
+#
+# Danga's Distributed Lock Daemon
+#
+# Status: 2004-05-18:  quick hack.  not for production yet.
+#
+# Copyright 2004, Danga Interactive
+#
+# Authors:
+#   Brad Fitzpatrick <brad@danga.com>
+#
+# License:
+#   undecided.
+#
+
+use strict;
+use Getopt::Long;
+use Carp;
+use Danga::Socket;
+use IO::Socket::INET;
+use POSIX ();
+
+use vars qw($DEBUG);
+$DEBUG = 0;
+
+my (
+    $daemonize,
+    $nokeepalive,
+   );
+my $conf_port = 7002;
+
+Getopt::Long::GetOptions(
+    'd|daemon'       => \$daemonize,
+    'p|port=i'       => \$conf_port,
+    'debug=i'        => \$DEBUG,
+    'n|no-keepalive' => \$nokeepalive,
+   );
+
+daemonize() if $daemonize;
+
+use Socket qw(IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET);
+
+# Linux-specific:
+use constant TCP_KEEPIDLE  => 4; # Start keeplives after this period
+use constant TCP_KEEPINTVL => 5; # Interval between keepalives
+use constant TCP_KEEPCNT   => 6; # Number of keepalives before death
+
+$SIG{'PIPE'} = "IGNORE";  # handled manually
+
+# establish SERVER socket, bind and listen.
+my $server = IO::Socket::INET->new(LocalPort => $conf_port,
+                                   Type      => SOCK_STREAM,
+                                   Proto     => IPPROTO_TCP,
+                                   Blocking  => 0,
+                                   Reuse     => 1,
+                                   Listen    => 10 )
+    or die "Error creating socket: $@\n";
+
+# Not sure if I'm crazy or not, but I can't see in strace where/how
+# Perl 5.6 sets blocking to 0 without this.  In Perl 5.8, IO::Socket::INET
+# obviously sets it from watching strace.
+IO::Handle::blocking($server, 0);
+
+my $accept_handler = sub {
+    my $csock = $server->accept();
+    return unless $csock;
+
+    printf("Listen child making a Client for %d.\n", fileno($csock))
+	if $DEBUG;
+
+    IO::Handle::blocking($csock, 0);
+    setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die;
+
+    # Enable keep alive
+    unless ( $nokeepalive ) {
+        (setsockopt($csock, SOL_SOCKET, SO_KEEPALIVE,  pack("l", 1)) &&
+         setsockopt($csock, IPPROTO_TCP, TCP_KEEPIDLE,  pack("l", 30)) &&
+         setsockopt($csock, IPPROTO_TCP, TCP_KEEPCNT,   pack("l", 10)) &&
+         setsockopt($csock, IPPROTO_TCP, TCP_KEEPINTVL, pack("l", 30)) &&
+         1
+        ) || die "Couldn't set keep-alive settings on socket (Not on Linux?)";
+    }
+
+    my $client = Client->new($csock);
+    $client->watch_read(1);
+};
+
+Client->OtherFds(fileno($server) => $accept_handler);
+Client->EventLoop();
+
+sub daemonize {
+    my($pid, $sess_id, $i);
+
+    ## Fork and exit parent
+    if ($pid = fork) { exit 0; }
+
+    ## Detach ourselves from the terminal
+    croak "Cannot detach from controlling terminal"
+        unless $sess_id = POSIX::setsid();
+
+    ## Prevent possibility of acquiring a controling terminal
+    $SIG{'HUP'} = 'IGNORE';
+    if ($pid = fork) { exit 0; }
+
+    ## Change working directory
+    chdir "/";
+
+    ## Clear file creation mask
+    umask 0;
+
+    ## Close open file descriptors
+    close(STDIN);
+    close(STDOUT);
+    close(STDERR);
+
+    ## Reopen stderr, stdout, stdin to /dev/null
+    open(STDIN,  "+>/dev/null");
+    open(STDOUT, "+>&STDIN");
+    open(STDERR, "+>&STDIN");
+}
+
+#####################################################################
+### C L I E N T   C L A S S
+#####################################################################
+package Client;
+
+use Danga::Socket;
+use base 'Danga::Socket';
+use fields (
+            'locks',  # hashref of locks held by this connection. values are 1
+            'read_buf',
+	    );
+
+our (%holder);  # hash of lock -> Client object holding it
+# TODO: out %waiters, lock -> arrayref of client waiters (waker should check not closed)
+
+sub new {
+    my Client $self = shift;
+    $self = fields::new($self) unless ref $self;
+    $self->SUPER::new( @_ );
+
+    $self->{locks} = {};
+    $self->{read_buf} = '';
+    return $self;
+}
+
+# Client
+sub event_read {
+    my Client $self = shift;
+
+    my $bref = $self->read(1024);
+    return $self->close() unless defined $bref;
+    $self->{read_buf} .= $$bref;
+
+    if ($self->{read_buf} =~ s/^(.+?)\r?\n//) {
+        my $line = $1;
+        $self->process_line( $line );
+    }
+}
+
+sub process_line {
+    my Client $self = shift;
+    my $line = shift;
+
+    if ($line =~ /^(\w+)\s*(.*)/) {
+        my ($cmd, $args) = ($1, $2);
+        $cmd = lc($cmd);
+
+        no strict 'refs';
+        my $cmd_handler = *{"cmd_$cmd"}{CODE};
+        if ($cmd_handler) {
+            my $args = decode_url_args(\$args);
+            $cmd_handler->($self, $args);
+            next;
+        }
+    }
+
+    return $self->err_line('unknown_command');
+}
+
+sub close {
+    my Client $self = shift;
+
+    foreach my $lock (keys %{$self->{locks}}) {
+	_release_lock($self, $lock);
+    }
+
+    $self->SUPER::close;
+}
+
+sub _release_lock {
+    my Client $self = shift;
+    my $lock = shift;
+
+    # TODO: notify waiters
+    delete $self->{locks}{$lock};
+    delete $holder{$lock};
+    return 1;
+}
+
+
+# Client
+sub event_err { my $self = shift; $self->close; }
+sub event_hup { my $self = shift; $self->close; }
+
+
+# gets a lock or fails with 'taken'
+sub cmd_trylock {
+    my Client $self = shift;
+    my $args = shift;
+
+    my $lock = $args->{lock};
+    return $self->err_line("empty_lock") unless length($lock);
+    return $self->err_line("taken") if defined $holder{$lock};
+
+    $holder{$lock} = $self;
+    $self->{locks}{$lock} = 1;
+
+    return $self->ok_line();
+}
+
+# releases a lock or fails with 'didnthave'
+sub cmd_releaselock {
+    my Client $self = shift;
+    my $args = shift;
+
+    my $lock = $args->{lock};
+    return $self->err_line("empty_lock") unless length($lock);
+    return $self->err_line("didnthave") unless $self->{locks}{$lock};
+
+    _release_lock($self, $lock);
+    return $self->ok_line;
+}
+
+# shows current locks
+sub cmd_locks {
+    my Client $self = shift;
+    my $args = shift;
+
+    $self->write("LOCKS:\n");
+    foreach my $k (sort keys %holder) {
+	$self->write("  $k = " . $holder{$k}->as_string . "\n");
+    }
+
+    return 1;
+}
+
+sub cmd_noop {
+    my Client $self = shift;
+    # TODO: set self's last activity time so it isn't cleaned in a purge
+    #       of stale connections?
+    return $self->ok_line;
+}
+
+sub ok_line {
+    my Client $self = shift;
+    my $args = shift || {};
+    my $argline = join('&', map { eurl($_) . "=" . eurl($args->{$_}) } keys %$args);
+    $self->write("OK $argline\r\n");
+    return 1;
+}
+
+sub err_line {
+    my Client $self = shift;
+    my $err_code = shift;
+    my $err_text = {
+        'unknown_command' => "Unknown server command",
+    }->{$err_code};
+
+    $self->write("ERR $err_code " . eurl($err_text) . "\r\n");
+    return 0;
+}
+
+sub eurl
+{
+    my $a = $_[0];
+    $a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
+    $a =~ tr/ /+/;
+    return $a;
+}
+
+sub durl
+{
+    my ($a) = @_;
+    $a =~ tr/+/ /;
+    $a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
+    return $a;
+}
+
+sub decode_url_args
+{
+    my $a = shift;
+    my $buffer = ref $a ? $a : \$a;
+    my $ret = {};
+
+    my $pair;
+    my @pairs = split(/&/, $$buffer);
+    my ($name, $value);
+    foreach $pair (@pairs)
+    {
+        ($name, $value) = split(/=/, $pair);
+        $value =~ tr/+/ /;
+        $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
+        $name =~ tr/+/ /;
+        $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
+        $ret->{$name} .= $ret->{$name} ? "\0$value" : $value;
+    }
+    return $ret;
+}
+
+
+# Local Variables:
+# mode: perl
+# c-basic-indent: 4
+# indent-tabs-mode: nil
+# End: