view release on metacpan or  search on metacpan

lib/Net/DHCP/Control/Generic.pm  view on Meta::CPAN

            key_type => undef,
            key => undef,
            attrs => {},
            handle => undef,
            handle_factory => 'Net::DHCP::Control::ServerHandle',
            callback => undef,
            callback_data => undef,
          },
  );

# Initialize the dhcpctl library when this module is loaded
Net::DHCP::Control::initialize();

sub croak {
  require Carp;
  *croak = \&Carp::croak;
  shift;
  for (@_) {
    s/%ERR/$Net::DHCP::Control::STATUS/g;
  }
  goto &croak;
}

sub new {
  my ($base, %opts) = @_;
  my $class = ref $base || $base;

  $base->validate_options(\%opts);

  my $authenticator;
  my $handle = delete($opts{handle}) 
    || $opts{handle_factory}->new($opts{handle_factory}->select_opts(\%opts, 'new'))
      || return;
  my $objkind = $ {"$class\::KIND"} 
    or $base->croak("Missing $class\::KIND variable; aborting");
  my $object = Net::DHCP::Control::new_object($handle, $objkind)
    or return;
  if ($opts{callback}) {
    Net::DHCP::Control::set_callback($object, $opts{callback}, $opts{callback_data})
        or return;
  }

  my $self = { OBJ => $object,
               KIND => $objkind,
               HANDLE => $handle,
               OPTS => \%opts,
               AUTH => $authenticator,
               CLASS => $class,
             };

  while (my ($name, $val) = each %{$opts{attrs}}) {
    my $type = $class->typeof_attr($name) || TP_UNSPECIFIED;
    Net::DHCP::Control::set_value($object, $name, $val, $type);
  }

  Net::DHCP::Control::open_object($object, $handle) or return;
  unless ($opts{callback}) {
    Net::DHCP::Control::wait_for_completion($object) or return;
  }

  bless $self => $class;
}


for my $key (qw(obj kind handle opts auth class lazy)) {
  my $methname = $key;
  *$methname = sub { $_[0]->{uc $methname} };
}

sub get {
  my ($self, $name, $type) = @_;
  $type ||= $self->typeof_attr($name);
  my $z = Net::DHCP::Control::get_value($self->obj, $name, $type);
  $z;
}


sub refresh {
  my ($self) = @_;
  Net::DHCP::Control::object_refresh($self);
}

sub set {
  my ($self, $name, $value, $type) = @_;
  $type ||= $self->typeof_attr($name);
  Net::DHCP::Control::set_value($self->obj, $name, $value, $type) or return;
  return 1 if $self->lazy;
  $self->update;
}

sub update {
  my $self = shift;
  Net::DHCP::Control::object_update($self->handle, $self->obj) or return;
  Net::DHCP::Control::wait_for_completion($self->obj) or return;
}

sub typeof_attr {
  my ($self, $name) = @_;
  my $class = ref $self ? $self->class : $self;
  $ {"$class\::ATTRS"}{$name};
}

sub attrs {
  my ($self, $name) = @_;
  my $class = ref $self ? $self->class : $self;
  keys % {"$class\::ATTRS"};
}

# return all available information about an object as a hash
sub get_all {
  my $self = shift;
  my %result;
  for my $attr ($self->attrs) {
    $result{$attr} = $self->get($attr);
  }
  %result;
}

sub validate_options {
  my $base = shift;
  my $class = ref $base || $base;