Drupal::Admin::ModuleState - screen scraping Perl API to Drupal module state

  use Drupal::ModuleState;

  $Drupal::ModuleState::COMMITMAXRETRIES = 7;

  my $state = new Drupal::ModuleState(
                                      mech => $obj,
                                      baseurl => $url
                                     );
  my @list = $state->list;
  my @groups = $state->groups;
  my @types = $state->types;

  $state->setstate(
                   state => 1,
                   group => 'Core - optional',
                   type => 'status',
                   modules => ['aggregator', 'blog', 'color']
                  );

  eval{ $state->commit };
  warn($@) if $@;




  $state->core_required_disable;

  eval{ $state->commit };
  warn($@) if $@;

#################################################################
# Drupal::Admin::ModuleState Package
#################################################################

package Drupal::Admin::ModuleState;

use Moose;
use Log::Log4perl qw(:easy);
with 'MooseX::Log::Log4perl::Easy';

use Drupal::Admin::ModuleCheckbox;
use strict;


#
# Maximum times to retry a commit
#
my $COMMITMAXRETRIES = 4;

has 'mech' => (
	       is => 'ro',
	       isa => 'WWW::Mechanize::TreeBuilder',
	       required => 1
	      );

has 'baseurl' => (
		  is => 'ro',
		  isa => 'Str',
		  required => 1
		 );

has 'modules' => (
		   is => 'rw',
		   isa => 'ArrayRef',
		   init_arg   => undef,
		   builder => '_build_modules'
 		 );

sub _build_modules {
  my($self) = @_;
  my $arref = $self->_getstate;
  return($arref);
}

# MooseX::Log::Log4perl::Easy apparently doesn't give use logwarn and
# logdie, so we need these
sub _warn {
  my($self,$msg) = @_;
  $self->log_warn($msg);
  warn($msg);
}


sub _die {
  my($self,$msg) = @_;
  $self->log_fatal($msg);
  die($msg);
}

#################################################################
# Public Methods
#################################################################

#
# List current module state in human readable form
#
sub list {
  my($self) = @_;

  # FIXME this somehow changes the object??
  #return( sort( map {$_->readable;} @{$self->modules} ) );

  my @list;
  foreach my $module ( @{$self->modules} ){
    push(@list, $module->readable);
  }

  return( sort(@list) );
}

#
# Return a list of current group names
#
sub groups {
  my($self) = @_;
  $self->log_trace("Entering groups()");

  my %groups;
  foreach my $module ( @{$self->modules} ){
    $groups{$module->group} = "";
  }

  $self->log_trace("Leaving groups()");
  return( sort( keys(%groups) ) );
}

#
# Return a list of current type names
#
sub types {
  my($self) = @_;

  $self->log_trace("Entering types()");

  my %types;
  foreach my $module ( @{$self->modules} ){
    $types{$module->type} = "";
  }

  $self->log_trace("Leaving types()");
  return( sort( keys(%types) ) );
}



# Toggle on/off one or more modules
#
# Args are state (1|0), group, optional type (status|throttle) and
# optional array of modules within that group to act on. If no
# type/modules are explicitly given, all modules in that group will be
# acted on. Note that NOT giving a type means that throttling e.g. will
# be enabled/disabled.
#
# WARNING: setstate will not create a new entry in the module array; 
# thus, if a module doesn't exist at the time in the list at the time it 
# is set (e.g. a throttle checkbox) it will be silently ignored. The solution
# to this is to call commit() between calls to setstate.
sub setstate {
  my($self, %params) = @_;

  my $state = $params{state};
  my $group = $params{group};
  my $type = $params{type};
  my $modvalues = $params{modules};

  my $logmsg = "Entering setstate( state => $state, group => $group";
  $logmsg .= ", type => $type" if $type;
  $logmsg .= " [modules arg not shown] )";
  $self->log_trace($logmsg);

  $self->_die("State must be boolean") unless defined($state) && ($state == 0 || $state == 1);
  $self->_die("Group is required") unless defined($group);
  $self->_die("No such module group") unless grep(/^$group$/, $self->groups);

  foreach my $module ( @{$self->modules} ) {
    next if $module->group ne $group;
    next if $type && $module->type ne $type;

    my $value = $module->value;
    next if $modvalues && !grep(/^$value$/,@{$modvalues});

    $module->checked($state);
    $self->log_debug("setstate(): Setting checkbox state: " . $module->readable);
  }

  $self->log_trace("Leaving setstate()");
}



#
# Disable all except 'Core - required'
#
sub core_required_disable {
  my($self) = @_;
  $self->log_trace("Entering core_required_disable()");

  my @groups = grep( !/^Core - required$/, $self->groups );
  foreach my $group (@groups){
    $self->setstate(state => 0, group => $group);
  }

  $self->log_trace("Leaving core_required_disable()");
}

#
# Commit current module state
#
# If we can't set a checkbox value (because it doesn't exist in the current page)
# AND the checkbox is checked, we will retry up to $COMMITMAXRETRIES. This means we
# ignore entries for missing checkboxes that are unchecked; i.e. we assume that
# any checkbox that doesn't appear on the page has the unchecked state.
#
sub commit {
  my($self) = @_;

  $self->log_trace("Entering commit()");

  my $url = $self->baseurl . '?q=admin/build/modules';
  $self->mech->get($url);
  $self->mech->form_id('system-modules');

  my $newstate;
  my $unsynced = 1;
  my $i = 1;
  while( $i <= $COMMITMAXRETRIES && $unsynced ){
    $self->log_debug("commit(): run $i");

    $i++;
    $unsynced = undef;

    my @fields;
    foreach my $module ( @{$self->modules} ){

      # Ignore modules in 'Core - required'
      next if $module->group eq 'Core - required';

      # Put this in an eval block so it doesn't die() if a field doesn't exist in the current page
      # This happens e.g. when throttling is disabled
      # NOTE: using tick() instead of field() doesn't allow us to use the index field,
      # but field() doesn't seem to work???
      #eval{ $self->mech->field($module->name, $module->checked, $module->index); };
      eval{ $self->mech->tick($module->name, $module->value, $module->checked); };
    }

    # Commit the changes
    my $response = $self->mech->click_button('name' => 'op');
    $self->_warn('Failed to submit page: ' . $response->status_line) unless $response->is_success;

    # Test to see whether all changes have been committed; retry if they haven't
    $self->mech->get($url);
    $self->mech->form_id('system-modules');
    $newstate = $self->_getstate;

    $unsynced = $self->_unsynced($self->modules, $newstate);
  }

  # Warn with a list of any out-of-sync modules
  if( $unsynced  ){

    $self->_warn(
		   join("\n",
			"commit() failed for the following modules:\n",
			@{$unsynced}
		       )
		   );
  }

  $self->modules($newstate);
  $self->log_trace("Leaving commit()");
}


#################################################################
# Private Methods
#################################################################

#
# Return a ref to a plain array of modules of the current website state
#
sub _getstate {
  my($self) = @_;

  $self->log_trace("Entering _getstate()");

  my $url = $self->baseurl . '?q=admin/build/modules';

  # Get and parse the status page
  $self->mech->get($url);

  my @result;

  # Get all the groups (fieldsets)
  my @group_trees = $self->mech->look_down("_tag", "fieldset");
  foreach my $group_tree (@group_trees) {
    my $group = $group_tree->look_down("_tag", 'legend')->as_text
      || $self->_die("Failed to extract module group name");

    # Get all the checkboxes for that group
    my @chboxes = $group_tree->look_down("_tag", "input",
					 "type", "checkbox");

    foreach my $chx (@chboxes) {

      my $name = $chx->attr_get_i('name');

      $name =~ /^(.*)\[/;
      my $type = $1;

      my $id  = $chx->attr_get_i('id');
      my $value = $chx->attr_get_i('value');
      my $checked = defined($chx->attr_get_i('checked')) ? 1 : 0;
      my $disabled = defined($chx->attr_get_i('disabled')) ? 1 : 0;

      # This must be called before creating the entry
      my $index = $self-> _module_name_index($name, \@result);

      my $chobj = new Drupal::Admin::ModuleCheckbox(
					     name => $name,
					     type => $type,
					     id => $id,
					     value => $value,
					     checked => $checked,
					     disabled => $disabled,
					     index => $index,
					     group => $group
					    );
      push( @result, $chobj );
    }

  }

  $self->log_trace("Leaving _getstate()");

  return(\@result);
}

#
# Since field names are not (necessarily) unique, return the index
# value of the given module name (for use with WWW::Mechanize).
# Indices start with 1. Second argument is ref to plain array of modules
# that we're to examine.
#
sub _module_name_index {
  my($self, $name, $modules) = @_;

  $self->log_trace("Entering _module_name_index()");

  # Find the greatest current index for this module name
  my $index = 0;
  foreach my $module ( @{$modules} ){
    $index = $module->index
      if $module->name eq $name && $module->index > $index
  }

  $self->log_trace("Leaving _module_name_index()");
  return($index++);
}

#
# Given references to two arrays of modules, desired and current,
# return a ref to a list of the desired that are not in the current.
# (This implies current can be a superset of desired)
#
sub _unsynced {
  my($self, $desired, $current) = @_;

  # Hash the desired modules; keys are the 'readable' strings minus the 'checked' field
  my %d;
  foreach my $module ( @{$desired} ){

    # skip 'Core - required'
    next if $module->group eq 'Core - required';

    # remove the 'checked' portion of the readable string
    my $key = $module->readable;
    $key =~ s/(\.\d)$//;

    $d{$key} = $module;
  }


  my %c;
  foreach my $module ( @{$current} ){

    # skip 'Core - required'
    next if $module->group eq 'Core - required';

    # remove the 'checked' portion of the readable string
    my $key = $module->readable;
    $key =~ s/(\.\d)$//;

    $c{$key} = $module;
  }

  my @mismatches;
  foreach my $k (keys %d) {
    my $desired = $d{$k};
    my $current = $c{$k};

    # Skip any that we want unchecked that don't exist in the current set
    # e.g. throttle checkboxes won't appear unless throttling is enabled
    #next if $desired->checked == 0 && !exists($c{$k});
    next if $desired->checked == 0 && !defined($current);

    # Skip any that have identical state
    next if $desired->checked == $current->checked;

    push (@mismatches, $desired->readable);
  }

  my @result = sort @mismatches;
  return(\@result) if scalar(@result);
}




no Moose;
__PACKAGE__->meta->make_immutable;

1;


__END__