File Coverage

blib/lib/XML/Debian/ENetInterfaces.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package XML::Debian::ENetInterfaces;

use warnings;
use strict;
require 5.10.0;

=head1 NAME

XML::Debian::ENetInterfaces - Work with Debian's /etc/network/interfaces in XML.

=head1 VERSION

Version 0.07

=cut

our $VERSION = '0.07';

use feature 'switch';
#use Data::Dumper;
use XML::LibXML;
use XML::Parser::PerlSAX;
use Fcntl qw(O_RDONLY O_WRONLY O_CREAT O_APPEND :flock);
use Carp;

sub read();
sub write;
sub lock;
sub relock;
sub unlock();
my @locked;
my $S;
my $dom;

=head1 SYNOPSIS

Import/Export Debian /etc/network/interfaces from/to XML.

    use XML::Debian::ENetInterfaces;
    XML::Debian::ENetInterfaces::lock(); # Optionally takes a Fcntl/flock
	# constant like LOCK_SH
    my $xmlstr = XML::Debian::ENetInterfaces::read();
    XML::Debian::ENetInterfaces::write('XML String'||
	IO::Handle->new('file','r'));
    XML::Debian::ENetInterfaces::unlock();

=head1 SUBROUTINES/METHODS

=head2 new

Just returns an object.

=cut

sub new {
  my ($class) = @_;
  return bless {}, $class;
}

=head2 lock

By default, no arguments, creates an exclusive semaphoric lock on at least the two files written to by this application.  Can be used to create a shared semaphoric lock, like so:

    use Fcntl qw(:flock);
    XML::Debian::ENetInterfaces::lock(LOCK_SH);

=cut

sub lock {
  my ($lvl)=@_;
  $lvl||=LOCK_EX;
  relock($lvl) if ( @locked );
  my $file=$ENV{INTERFACES}||'/etc/network/interfaces';
  my $SEMAPHORE=$file.'.lck';
  sysopen($S,$SEMAPHORE,
    ($lvl==LOCK_SH?O_RDONLY:O_WRONLY)|O_CREAT|O_APPEND) or
    die "$SEMAPHORE: $!";
  flock($S,$lvl) or die "flock() failed for $SEMAPHORE: $!";
  @locked=($file,$lvl);
}

=head2 relock

Used internally to detect in proper Round Trip locking.  May also be useful to you.  Takes the same arguments as lock above.

=cut

sub relock {
  carp "Re-locking, sounds like an issue with Round Trip.";
  my ($lvl)=@_;
  $lvl||=LOCK_EX;
  my $file = $ENV{INTERFACES}||'/etc/network/interfaces';
  carp "Re-locking wrong file: $file" unless ( $file eq $locked[0] );
  croak "Semaphore not open." unless (defined $S);
  flock($S, $lvl) or die "flock() failed for $file.lck: $!";
  $locked[1] = $lvl;
}

=head2 unlock

Close the existing lock.

=cut

sub unlock() {
  my $file = $ENV{INTERFACES}||'/etc/network/interfaces';
  carp "Unlocking wrong file: $file" unless ( $file eq $locked[0] );
  croak "Semaphore not open." unless (defined $S);
  close $S;
  $S=undef;
  @locked=();
}

sub __identattr
{
  my ($attr, $str)= @_;
  $attr = $dom->createAttribute($attr); # Scary.
  while ($str =~ m/(.)/g) {
    given ($1){
      when (" ") { $attr->appendChild($dom->createEntityReference('#32')); }
      when ("\t") { $attr->appendChild($dom->createEntityReference('#9')); }
      default { warn $1; $attr->appendChild($dom->createTextNode($1)); }
    }
  }
  return $attr;
}

=head2 read

Takes no arguments and returns a string containing XML.

=cut

sub read() {
  my $RootName='etc_network_interfaces';
  # NOTE: The example file uses 8 space indents, the DTD specifies
  #       4 spaces as the default.
  # This cheat is used because DTD creation is not yet implemented.
  $dom = XML::LibXML->load_xml(string => <");






	_indent CDATA   ""
	_alias CDATA   #IMPLIED
  >


	name CDATA   #REQUIRED
	opts CDATA   #REQUIRED
	_indent CDATA   ""
	_childindent CDATA   "    "
	_alias CDATA   #IMPLIED
	address CDATA #IMPLIED
	network CDATA #IMPLIED
	broadcast CDATA #IMPLIED
	gateway CDATA #IMPLIED
	dns-nameservers CDATA #IMPLIED
	netmask CDATA #IMPLIED
	ttl CDATA #IMPLIED
	local CDATA #IMPLIED
	remote CDATA #IMPLIED
	mtu CDATA #IMPLIED
	endpoint CDATA #IMPLIED
  >


	name CDATA   #REQUIRED
	opts CDATA   #REQUIRED
	script CDATA   #REQUIRED
	_indent CDATA   ""
	_alias CDATA   #IMPLIED
	_childindent CDATA   "    "
  >


	_indent CDATA   "    "
  >


	_indent CDATA   "    "
	_alias CDATA   #IMPLIED
  >


	_indent CDATA   "    "
  >


	_indent CDATA   "    "
	_alias CDATA   #IMPLIED
  >


	_indent CDATA   "    "
  >

]>
END

  my $root = $dom->documentElement();

  # Any lock will do.
  my $waslocked = @locked;
  lock(LOCK_SH) unless ($waslocked);
  my $file = $ENV{INTERFACES}||'/etc/network/interfaces';
  open (my $INTER, '<', $file) or croak "Can't read $file: $!";

  my $domptr;
  LINE: while (my $ln=<$INTER>) {
    chomp $ln;
    # A line may be extended across multiple lines by making the
    # last character a backslash.
    while ($ln =~ /\\$/) {
      # Removes/joins extended lines.
      # TODO: Fix case where result has no whitespace.
      chop $ln; chomp($ln.=<$INTER>); last if (eof $INTER);
    }
    # warn $ln;
    # White space around comments is written out.
    if ($ln =~ /^\s*#/ ) {
      my $element = $dom->createElement('COMMENT');
      $element->appendChild($dom->createTextNode($ln));
      if (defined $domptr) {
	$domptr->appendChild($element);
      } else {
	$root->appendChild($element);
      }
      next LINE;
    }
    # Removes white space on blank lines.
    if ($ln eq '' or $ln =~ /^\s*$/) {
      if (defined $domptr) {
	$domptr->appendChild($dom->createElement('br'));
      } else {
	$root->appendChild($dom->createElement('br'));
      }
      next LINE;
    }
    # This loop could be done within the regex,
    # though I originally wrote it this way...  no particular reason.
    foreach my $rx (qr(auto),qr(allow-auto),qr(allow-[^ ]*),
	qr(mapping),qr(iface)) {
      if ($ln =~ /^(\s*)($rx)\s+(\S*)\s*(.*)$/) {
	my ($ind,$ele,$nam,$opt) = ($1,$2,$3,$4);
	$domptr = undef;
	my $element = $dom->createElement($ele);
	given ($ele){
	  when('mapping') {
	    $element->addChild($dom->createAttribute('name', $nam));
	    $element->addChild($dom->createAttribute('opts', $opt));
	    $element->addChild(__identattr('_indent',$ind));
	    $domptr = $element;
	  }
	  when('iface') {
	    $element->addChild($dom->createAttribute('name', $nam));
	    $element->addChild($dom->createAttribute('opts', $opt));
	    $element->addChild(__identattr('_indent',$ind));
	    $domptr = $element;
	  }
	  when('allow-auto') {
	    $element = $dom->createElement('auto');
	    $element->addChild(__identattr('_alias',$ele));
	    $element->addChild(__identattr('_indent',$ind));
	    $element->appendChild($dom->createTextNode(join ' ', grep /./, $nam, $opt));
	  }
	  default {
	    $element->addChild(__identattr('_indent',$ind));
	    $element->appendChild($dom->createTextNode(join ' ', grep /./, $nam, $opt));
	  }
	}
	$root->appendChild($element);
	next LINE;
      }
    }
    if ($ln =~ /^(\s*)(\S*)\s(.*)$/) {
      my ($ind,$ele,$dat) = ($1,$2,$3);
      if (defined $domptr) {
	given ($ele){
	  when(['post-up', 'pre-down']) {
	    carp unless ($domptr->tagName eq 'iface');
	    my $aele = $ele;
	    $aele=~s/^.*(up|down)/$1/;
	    my $element = $dom->createElement($aele);
	    $element->addChild(__identattr('_alias',$ele));
	    $element->addChild(__identattr('_indent',$ind));
	    $element->appendChild($dom->createTextNode($dat));
	    $domptr->appendChild($element);
	  }
	  when('map') {
	    carp unless ($domptr->tagName eq 'mapping');
	    my $element = $dom->createElement($ele);
	    $element->addChild(__identattr('_indent',$ind));
	    $element->appendChild($dom->createTextNode($dat));
	    $domptr->appendChild($element);
	  }
	  when(['up','down','pre-up','post-down']) {
	    carp unless ($domptr->tagName eq 'iface');
	    my $element = $dom->createElement($ele);
	    $element->addChild(__identattr('_indent',$ind));
	    $element->appendChild($dom->createTextNode($dat));
	    $domptr->appendChild($element);
	  }
	  default {
	    $domptr->addChild(__identattr('_childindent',$ind))
	      unless (defined $domptr->getAttributeNode('_childindent') );
	    $domptr->addChild($dom->createAttribute($ele,$dat));
	  }
	}
	next LINE;
      }
      warn $ln;
      next LINE;
    }
    warn $ln;
  }
  close $INTER;
# Should not hurt and is useful for Round Trip detection.
#  unlock() unless ($waslocked);

  my $out = $dom->toString(1);
  $dom=undef;
  return $out;
}

=head2 write

Takes either a string or a file handle, per IO::Handle understanding of what a file handle is, and passes this to XML::Parser::PerlSAX as a string.  Current versions of XML::Parser::PerlSAX treat this identically to an IO::Handle, though I guess one couldn't count on that continually being the case.

Passed to XML-Parser-2.41(XML::Parser->parse($parse_options->{Source}{String})), libxml-perl-0.08(XML::Parser::PerlSAX->new({Source=>{String=>$_[0]}}))'s back-end.

=cut

sub write {
  my ($inp) = @_;
  # Make sure the lock is exclusive.
  my $waslocked = (@locked and $locked[1]||-1==LOCK_EX);
  lock(LOCK_EX) unless ($waslocked);
  my $file = $ENV{INTERFACES}||'/etc/network/interfaces';
  open (my $INTER, '>', "$file.tmp") or die "Can't write $file.tmp: $!";
  my $handler = XML::Debian::ENetInterfaces::Handler->new($INTER);
  my $parser = XML::Parser::PerlSAX->new(
    Handler=>$handler,
    UseAttributeOrder=>1,
    Source=>{String=>$inp}
  );
  $parser->parse();

  close $INTER;
  rename("$file.tmp", $file);
  unlock() unless ($waslocked);

}

1;
package XML::Debian::ENetInterfaces::Handler;
use warnings;
use strict;
require 5.10.0;
use feature 'switch';
#use Data::Dumper;

sub new {
  my ($class,$outp) = @_;
  return bless {INTER=>$outp}, $class;
}

my $last_element;
my $last_alias;
my $childindent;
my $indent;
sub start_element {
  my ($self, $element) = @_;
  my $fh = $self->{INTER};
  $last_element=$element->{Name};
  $last_alias=$element->{Attributes}->{_alias}||$last_element;
  given ($last_element){
    when(undef) { warn; }
    when('br') { print $fh "\n"; }
    when(['iface','mapping']) {
      print $fh join(' ', grep /./,
	"$element->{Attributes}->{_indent}$last_alias",
	$element->{Attributes}->{name},
	$element->{Attributes}->{opts}),"\n";
      $childindent=$element->{Attributes}->{'_childindent'};
      delete $element->{Attributes}->{name};
      delete $element->{Attributes}->{opts};
      delete $element->{Attributes}->{_alias};
      delete $element->{Attributes}->{_indent};
      delete $element->{Attributes}->{_childindent};
      for (@{$element->{AttributeOrder}}) {
	my $tmp = $_;
	print $fh "$childindent$tmp $element->{Attributes}->{$tmp}\n"
	  unless ($tmp =~ /^_/ or !defined $element->{Attributes}->{$tmp});
      }
    }
    default { $indent=$element->{Attributes}->{'_indent'}; }
  }
}

sub end_element {
  my ($self, $element) = @_;
  given ($last_element||'nomatch'){
    when(['iface','mapping']) {
      $childindent=undef;
      continue;
    }
    when($element->{Name}) {
      $last_element=undef;
      $last_alias=undef;
      $indent=undef;
    }
  }
}

sub characters {
  my ($self, $characters) = @_;
  my $fh = $self->{INTER};
#  warn Dumper(\$characters);
  my $hack='__NEVERMATCH';
  given ($last_element){
    when(undef) {}
    when(['etc_network_interfaces','iface','mapping']) {}
    when('COMMENT') { print $fh "$characters->{Data}\n"; }
    when(/allow-[^ ]*/) { $hack=$last_element; continue; }
    when(['up','down','post-up','pre-down','auto',$hack]) {
      print $fh "$indent$last_alias $characters->{Data}\n"; }
    default { print $fh "$indent$last_alias $characters->{Data}\n"; }
  }
}

1;
__END__