Cache::Memcached::Admin

Adminってもんでもないけど、
いちいちtelnetで話すのも面倒だしみたいな。
すげーてきとう。

package Cache::Memcached::Admin;
use strict;
use warnings;
use base qw/Class::Accessor::Fast/;

use Term::ReadLine;
use File::HomeDir;
use Path::Class;
use List::MoreUtils qw/uniq/;
use Cache::Memcached;

sub run {
    my $self = shift;

    my $term = Term::ReadLine->new('Cache::Memcached::Admin');
    my $HISTFILE = file( File::HomeDir->my_home, '/.memcached_admin_history');
    my $HISTSIZE = 256;

    # this won't work with Term::ReadLine::Perl
    # If there is Term::ReadLine::Gnu, be sure to do : export "PERL_RL=Gnu o=0"
    eval { $term->stifle_history($HISTSIZE) };
    if ($!) {
        warn 'You will need Term::ReadLine::Gnu';
    } else {
        if ( -f $HISTFILE ) {
            $term->ReadHistory($HISTFILE) or warn  "cannot read history file: $!";
        }
    }

    while ( defined( my $line = $term->readline('memcached> ') ) ) {
        next if $line =~ /^\s*$/;
        my $ret = $self->run_hook($line);
        last if $ret eq 'exit';
    }
    print "\n";

    eval { $term->WriteHistory($HISTFILE) };
    if (@!) {
        warn "perlsh: cannot write history file: $!";
    }
}

sub run_hook {
    my ( $self, $cmd ) = @_;

    if    ( $cmd =~ /^!set\s+(.+)$/ ) {
        $self->set_servers( $self->_ip_setting($1) );
    }
    elsif ( $cmd =~ /^!get$/ ) {
        $self->get_servers;
    }
    elsif ( $cmd =~ /^!remove\s+(.+)$/ ) {
        $self->remove_servers( $self->_ip_setting($1) );
    }
    elsif ( $cmd =~ /^!flush$/ ) {
        $self->flush_servers;
    }
    elsif ( $cmd =~ /^set\s+(.+)\s+(.+)$/ ) {
        $self->set_value($1,$2);
    }
    elsif ( $cmd =~ /^get\s+(.+)$/ ) {
        $self->get_value($1);
    }
    elsif ( $cmd =~ /^delete\s+(.+)$/ ) {
        $self->delete_value($1);
    }
    elsif ( $cmd =~ /^(quit|exit)$/ ) {
        print "see you... \n";
        return 'exit';
    }
}

sub delete_value {
    my ($self,$key) = @_;
    $self->memd->delete($key);
}
sub set_value {
    my ($self, $key, $value) = @_;
    $self->memd->set( $key,$value );
}
sub get_value {
    my ($self, $key) = @_;
    my $value = $self->memd->get( $key ) || '';
    print "$value\n";
}

sub _ip_setting {
    my ($self, $ip) = @_;
    my $fullip = $ip =~ /.+:\d+$/ ? $ip : "$ip:11211";
    return $fullip
}

sub flush_servers {
    my $self = shift;
    $self->memd->set_servers([]);
}

sub get_servers {
    my $self = shift;
    my $servers = $self->memd->{servers} || [];
    print "server settings----\n";
    print "$_\n" for @{$servers};
}

sub set_servers {
    my ($self, $server) = @_;
    my $servers = $self->memd->{servers} || [];
    push @{$servers},$server;
    my @new_servers = uniq @{$servers};
    $self->memd->set_servers(\@new_servers);
}

sub remove_servers {
    my ($self, $server) = @_;
    my @new_servers = grep { $_ ne $server } @{$self->memd->{servers} || []};
    $self->memd->set_servers(\@new_servers);
}

sub memd {
    my $self = shift;
    $self->{_memd} ||= Cache::Memcached->new;
}

1;

本当はSwitch.pm使いたかったけど、正規表現の部分をごりっと抜き出せないからやめた。
ほんとできないのかな？