File Coverage

blib/lib/Mobile/UserAgentFactory.pm

Criterion	Covered	Total	%
statement	12	127	9.4
branch	0	50	0.0
condition	0	33	0.0
subroutine	4	13	30.7
pod	1	1	100.0
total	17	224	7.5

package Mobile::UserAgentFactory;
use strict;
use Mobile::UserAgent;
use base qw(Class::Singleton);
our $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ m/ (\d+) \. (\d+) /xg;


# Contructor called by Class::Singleton to initialize a new instance.
sub _new_instance {
  my $proto = shift;
  my $options = shift;
  my $class = ref($proto) || $proto;
  my %cache_options;
  if (defined($options) && (ref($options) eq 'HASH')) {
    if (defined($options->{'cache_expires_in'})) {
      $cache_options{'expires_in'} = $options->{'cache_expires_in'};
    }
    if (defined($options->{'cache_purge_interval'})) {
      $cache_options{'purge_interval'} = $options->{'cache_purge_interval'};
    }
    if (defined($options->{'cache_max_age'})) {
      $cache_options{'max_age'} = $options->{'cache_max_age'};
    }
    if (defined($options->{'cache_max_objects'})) {
      $cache_options{'max_objects'} = $options->{'cache_max_objects'};
    }
  }
  my $self = {
   'cache' => Mobile::UserAgentFactoryCache->new(\%cache_options), # internal class
	};
  bless $self,$class;
  return $self;
}



# Uses the given useragent string to return a Mobile::UserAgent object if a match can be found.
sub getMobileUserAgent {
  my $self = shift;
  my $useragent;
  my $debug = 0;
  if (@_) {
    if (ref($_[0]) eq '') {
      $useragent = shift;
    }
    elsif (UNIVERSAL::isa(ref($_[0]), 'CGI')) {
      my $q = shift;
      $useragent = $q->user_agent();
    }
  }
  if (@_ && (ref($_[0]) eq 'HASH')) {
    my $options = shift;
    if (defined($options->{'debug'})) {
      $debug = $options->{'debug'};
    }
  }
  unless(defined($useragent)) {
    $useragent = $ENV{'HTTP_USER_AGENT'};
    unless(defined($useragent)) {
      $debug && print("Returning undef, because no user-agent was found in env vars.\n");
      return undef;
    }
  }

  # Try to fetch object from internal cache.
  my $cache = $self->{'cache'};
  my $mua = $cache->get($useragent);
  if (defined($mua) || $cache->key_exists($useragent)) {
    $debug && print("Returning Mobile::UserAgent object found in internal cache.\n");
    return $mua;
  }

  # Create new Mobile::UserAgent object, cache it, and return it.
  $mua = Mobile::UserAgent->new($useragent);
  $cache->set($useragent, $mua);
  return $mua;
}

1;

#### end of Mobile::UserAgentFactory ####











# Internal cache manager class.
package Mobile::UserAgentFactoryCache;
use strict;


# Contructor. Accepts an optional hash ref of options.
sub new {
  my $proto = shift;
  my $options = shift;
  my $class = ref($proto) || $proto;
  my $expires_in = 86400; # 1 day
  my $purge_interval = 3600; # 1 hour
  my $max_age = 604800; # 1 week
  my $max_objects = 1000;
  if (defined($options) && (ref($options) eq 'HASH')) {
    if (defined($options->{'expires_in'}) && $options->{'expires_in'}) {
      $expires_in = $options->{'expires_in'};
    }
    if (defined($options->{'purge_interval'}) && $options->{'purge_interval'}) {
      $purge_interval = $options->{'purge_interval'};
    }
    if (defined($options->{'max_age'}) && $options->{'max_age'}) {
      $max_age = $options->{'max_age'};
    }
    if (defined($options->{'max_objects'}) && $options->{'max_objects'}) {
      $max_objects = $options->{'max_objects'};
    }
  }
  my $self = {
	'objects'        => {}, # Cache of key => [object, create-time, last-access-time]
	'expires_in'     => $expires_in,
	'purge_interval' => $purge_interval,
	'max_age'        => $max_age,
	'max_objects'    => $max_objects,
	'last_purge'     => time,
	'max_objects_check_interval' => int($max_objects / 10), # after this many set() calls, the limit_max_objects() call will be executed.
	'max_objects_set_counter' => 0, # increases with each set() method call and is reset with with each limit_max_objects() call.
	};
  bless $self,$class;
  return $self;
}


# Checks if a key exists in the cache.
sub key_exists {
  my $self = shift;
  my $key = shift;
  return exists($self->{'objects'}->{$key});
}


# Gets a cached object.
sub get {
  my $self = shift;
  my $key = shift;
  my $objects = $self->{'objects'};
  my $result;
  if (exists($objects->{$key})) {
    my $object = $objects->{$key};
    $result = $object->[0];
    $object->[2] = time;
  }
  $self->_purge();
  return $result;
}


# Simply calls purge() if it's time to do so.
sub _purge {
  my $self = shift;
  if ($self->{'last_purge'} + $self->{'purge_interval'} <= time) {
    return $self->purge();
  }
  return 0;
}


# Purges all cached objects that have not been accessed recently or are too old.
sub purge {
  my $self = shift;
  my $objects = $self->{'objects'};
  my $now = time;
  my $max_age = $self->{'max_age'};
  my $expires = $self->{'expires_in'};
  my $result = 0;
  foreach my $key (keys %{$objects}) {
    my $object = $objects->{$key};
    if (($object->[2] + $expires <= $now) || ($object->[1] + $max_age <= $now)) {
      print "About to purge key: $key\n";
      delete($objects->{$key});
      $result++;
    }
  }
  $self->{'last_purge'} = $now;
  return $result;
}


# Sets a new object.
sub set {
  my $self = shift;
  my $key = shift;
  my $object = shift;
  my $now = time;
  $self->{'objects'}->{$key} = [$object, $now, $now];
  if (++$self->{'max_objects_set_counter'} >= $self->{'max_objects_check_interval'}) {
    return $self->limit_max_objects();
  }
}


# Shrinks the cache to 10% below max if max has been exceeded by 10%.
sub limit_max_objects {
  my $self = shift;
  $self->_purge();
  my $objects = $self->{'objects'};
  my $size = scalar(keys(%{$objects}));
  my $max_objects = $self->{'max_objects'};
  if ($size <= $max_objects) {
    return 0;
  }
  # sort keys on last-access-time descending
  my @sorted_keys = sort { $objects->{$b}->[2] <=> $objects->{$a}->[2] } keys(%{$objects});
  my @expired_keys = splice(@sorted_keys, $max_objects - 1 - int(0.2 * $max_objects)); # shrink to 20% below max
  #print 'About to delete keys: ' . join(' ', @expired_keys) . "\n";
  foreach my $key (@expired_keys) {
    delete($objects->{$key});
  }
  $self->{'max_objects_set_counter'} = 0;
  return scalar(@expired_keys);
}

#### end of Mobile::UserAgentFactoryCache ####
1;


__END__