view release on metacpan or  search on metacpan

lib/Apache/Session/Browseable/Redis.pm  view on Meta::CPAN

sub searchOn {
    my ( $class, $args, $selectField, $value, @fields ) = @_;

    my %res = ();
    if ( $class->isIndexed( $args, $selectField ) ) {

        my $redisObj  = $class->_getRedis($args);
        my $index_key = "${selectField}_$value";
        my @keys      = $redisObj->smembers($index_key);
        foreach my $k (@keys) {
            next unless ($k);
            my $tmp = $redisObj->get($k);
            unless ($tmp) {
                # Lazy cleanup: remove orphan from index
                eval { $redisObj->srem( $index_key, $k ) };
                next;
            }
            eval {
                $tmp = unserialize($tmp);
                if (@fields) {
                    $res{$k}->{$_} = $tmp->{$_} foreach (@fields);
                }
                else {
                    $res{$k} = $tmp;
                }
            };
            if ($@) {
                print STDERR "Error in session $k: $@\n";
                delete $res{$k};
            }
        }
    }
    else {
        $class->get_key_from_all_sessions(
            $args,
            sub {
                my $entry = shift;
                my $id    = shift;
                return undef
                  unless ( defined $entry->{$selectField}
                    and $entry->{$selectField} eq $value );
                if (@fields) {
                    $res{$id}->{$_} = $entry->{$_} foreach (@fields);
                }
                else {
                    $res{$id} = $entry;
                }
                undef;
            }
        );
    }
    return \%res;
}

sub searchOnExpr {
    my ( $class, $args, $selectField, $value, @fields ) = @_;
    my %res;
    if ( $class->isIndexed( $args, $selectField ) ) {
        my $redisObj = $class->_getRedis($args);
        my $cursor   = 0;
        do {
            my ( $new_cursor, $sets ) =
              $redisObj->scan( $cursor, MATCH => "${selectField}_$value" );
            foreach my $set (@$sets) {
                next unless $redisObj->type($set) eq 'set';
                my @keys = $redisObj->smembers($set);
                foreach my $k (@keys) {
                    my $v = $redisObj->get($k);
                    unless ($v) {
                        # Lazy cleanup: remove orphan from index
                        eval { $redisObj->srem( $set, $k ) };
                        next;
                    }
                    my $tmp = unserialize($v);
                    if ($tmp) {
                        $res{$k} = $class->extractFields( $tmp, @fields );
                    }
                }
            }
            $cursor = $new_cursor;
        } while ( $cursor != 0 );
    }
    else {
        $value = quotemeta($value);
        $value =~ s/\\\*/\.\*/g;
        $value = qr/^$value$/;
        $class->get_key_from_all_sessions(
            $args,
            sub {
                my ( $entry, $id ) = @_;
                return undef unless ( $entry->{$selectField} =~ $value );
                $res{$id} = $class->extractFields( $entry, @fields );
                undef;
            }
        );
    }
    return \%res;
}

sub deleteIfLowerThan {
    my ( $class, $args, $rule ) = @_;
    my $deleted  = 0;
    my $redisObj = $class->_getRedis($args);
    my $index =
      ref( $args->{Index} )
      ? $args->{Index}
      : [ split /\s+/, $args->{Index} ];

    $class->get_key_from_all_sessions(
        $args,
        sub {
            my ( $v, $k ) = @_;
            if ( $rule->{not} ) {
                foreach ( keys %{ $rule->{not} } ) {
                    if (defined( $v->{$_} ) and $v->{$_} eq $rule->{not}->{$_}) {
                        return ();
                    }
                }
            }
            # Empty or data-less sessions should be purged
            my $dominated = 0;
            if ( !$v || !%$v || !exists $v->{_session_id} ) {
                $dominated = 1;
            }
            elsif ( $rule->{or} ) {
                foreach ( keys %{ $rule->{or} } ) {
                    if ( !defined( $v->{$_} ) ) {
                        # Session missing a required field: treat as expired
                        $dominated = 1;
                        last;
                    }
                    if ( $v->{$_} < $rule->{or}->{$_} ) {
                        $dominated = 1;
                        last;
                    }
                }
            }
            elsif ( $rule->{and} ) {
                my $res = 1;
                foreach ( keys %{ $rule->{and} } ) {
                    $res = 0

lib/Apache/Session/Browseable/Redis.pm  view on Meta::CPAN

                      or $v->{$_} < $rule->{and}->{$_};
                }
                $dominated = $res;
            }
            if ($dominated) {
                # Clean up index entries before deleting the session
                my $index_ok = 1;
                foreach my $i (@$index) {
                    my $t = $v->{$i};
                    next unless ( defined($t) and length($t) > 0 );
                    eval { $redisObj->srem( "${i}_$t", $k ) };
                    if ($@) {
                        warn "Failed to remove '$k' from index '${i}_$t': $@";
                        $index_ok = 0;
                    }
                }
                if ($index_ok) {
                    $redisObj->del($k);
                    $deleted++;
                }
                else {
                    warn "Skipping deletion of session '$k' due to index cleanup failure";
                }
            }
            return ();
        },
    );
    return ( 1, $deleted );
}

sub extractFields {
    my ( $class, $entry, @fields ) = @_;
    my $res;
    if (@fields) {
        $res->{$_} = $entry->{$_} foreach (@fields);
    }
    else {
        $res = $entry;
    }
    return $res;
}

sub isIndexed {
    my ( $class, $args, $field ) = @_;
    my $indexes =
      ref( $args->{Index} ) ? $args->{Index} : [ split /\s+/, $args->{Index} ];
    return grep { $_ eq $field } @$indexes;
}

sub isLlngKey {
    my ( $class, $args, $name ) = @_;
    my $expr = $args->{keysRe} || '^[0-9a-f]{32,}$';
    return ( $name =~ /$expr/o );
}

sub get_key_from_all_sessions {
    my ( $class, $args, $data ) = @_;
    my %res;

    my $redisObj = $class->_getRedis($args);
    my $cursor   = 0;
    do {
        my ( $new_cursor, $keys ) = $redisObj->scan($cursor);
        foreach my $k (@$keys) {

            # Keep only our keys
            next unless $class->isLlngKey( $args, $k );

            # Don't scan sets,...
            next unless $redisObj->type($k) eq 'string';
            eval {
                my $v = $redisObj->get($k);
                next unless $v;
                my $tmp = unserialize($v);
                if ( ref($data) eq 'CODE' ) {
                    $tmp = &$data( $tmp, $k );
                    $res{$k} = $tmp if ( defined($tmp) );
                }
                elsif ($data) {
                    $data = [$data] unless ( ref($data) );
                    $res{$k}->{$_} = $tmp->{$_} foreach (@$data);
                }
                else {
                    $res{$k} = $tmp;
                }
            };
            if ($@) {
                print STDERR "Error in session $k: $@\n";

                # Don't delete, it may own to another app
                #delete $res{$k};
            }
        }
        $cursor = $new_cursor;
    } while ( $cursor != 0 );
    return \%res;
}

sub _getRedis {
    my ( $class, $args ) = @_;
    return Apache::Session::Browseable::Store::Redis->_getRedis($args);
}

1;
__END__

=head1 NAME

Apache::Session::Browseable::Redis - Add index and search methods to
Apache::Session::Redis

=head1 SYNOPSIS

  use Apache::Session::Browseable::Redis;

  my $args = {
       server => '127.0.0.1:6379',

       # Select database (optional)
       #database => 0,

       # Use a persistent connection to the Redis server
       # (value is the connection cache key)
       # You'll probably also want to set
       # read_timeout, write_timeout, reconnect and every
       reuse => "myserver",

       # Choose your browseable fields
       Index          => 'uid mail',

       # Optional: set a Redis TTL on session keys (in seconds)
       # TTL => 86400,
  };
  
  # Use it like Apache::Session
  my %session;
  tie %session, 'Apache::Session::Browseable::Redis', $id, $args;
  $session{uid} = 'me';
  $session{mail} = 'me@me.com';
  $session{unindexedField} = 'zz';
  untie %session;
  
  # Apache::Session::Browseable add some global class methods
  #
  # 1) search on a field (indexed or not)
  my $hash = Apache::Session::Browseable::Redis->searchOn( $args, 'uid', 'me' );
  foreach my $id (keys %$hash) {
    print $id . ":" . $hash->{$id}->{mail} . "\n";
  }

  # 2) Parse all sessions
  # a. get all sessions
  my $hash = Apache::Session::Browseable::Redis->get_key_from_all_sessions($args);

  # b. get some fields from all sessions