DAHDI-perl: allow setting base of system files with DAHDI_VIRT_TOP

If the user set DAHDI_VIRT_TOP in the environment, consider it as a path
under which to look for ProcFS and SysFS files. This allows running the
DAHDI-perl tools on filesystem dumps generated by
build_tools/dump_sys_state .

To reduce the number of dependencies between various modules, the 'xpd'
member of a Dahdi::Span is removed. Dahdi::Xpp::xpd_of_span() can be
used if needed.


git-svn-id: http://svn.asterisk.org/svn/dahdi/tools/trunk@8215 a0bf4364-ded3-4de4-8d8a-66a801d63aff

8 files changed, 51 insertions, 29 deletions

diff --git a/xpp/lsdahdi b/xpp/lsdahdi
index 1298c3e..e4d473c 100755
--- a/xpp/lsdahdi
+++ b/xpp/lsdahdi
@@ -22,7 +22,7 @@ my @xpds = map { $_->xpds } @xbuses;
 
 foreach my $span (Dahdi::spans()) {
 	my $spanno = $span->num;
-	my $xpd = $span->xpd;
+	my $xpd = Dahdi::Xpp::xpd_of_span($span);
 	my @lines;
 	my $index = 0;
 
diff --git a/xpp/perl_modules/Dahdi.pm b/xpp/perl_modules/Dahdi.pm
index fa5955a..e17b939 100644
--- a/xpp/perl_modules/Dahdi.pm
+++ b/xpp/perl_modules/Dahdi.pm
@@ -32,7 +32,11 @@ hardware and loaded Dahdi devices.
   }
 =cut
 
-my $proc_base = "/proc/dahdi";
+our $virt_base;
+our $proc_dahdi_base;
+our $proc_xpp_base;
+our $proc_usb_base;
+our $sys_base;
 
 =head1 spans()
 
@@ -43,10 +47,9 @@ Returns a list of span objects, ordered by span number.
 sub spans() {
 	my @spans;
 
-	-d $proc_base or return ();
-	foreach my $zfile (glob "$proc_base/*") {
-		$zfile =~ s:$proc_base/::;
-		next unless ($zfile =~ /^\d+$/);
+	-d $proc_dahdi_base or return ();
+	foreach my $zfile (glob "$proc_dahdi_base/*") {
+		next unless ($zfile =~ m{^$proc_dahdi_base/\d+$});
 		my $span = Dahdi::Span->new($zfile);
 		push(@spans, $span);
 	}
@@ -54,6 +57,13 @@ sub spans() {
 	return @spans;
 }
 
+=head1 ENVIRONMENT
+
+If C<DAHDI_VIRT_TOP> is set in the environment, it will be considered
+as a path to a directory that holds a dump (copy) of all the required
+files from /proc and /sys . You can generate that directory using the
+script C<build_tools/dump_sys_state> .
+
 =head1 SEE ALSO
 
 Span objects: L<Dahdi::Span>.
diff --git a/xpp/perl_modules/Dahdi/Hardware/PCI.pm b/xpp/perl_modules/Dahdi/Hardware/PCI.pm
index f6b3901..a1ef6bb 100644
--- a/xpp/perl_modules/Dahdi/Hardware/PCI.pm
+++ b/xpp/perl_modules/Dahdi/Hardware/PCI.pm
@@ -170,7 +170,7 @@ sub readfile($) {
 sub scan_devices($) {
 	my @devices;
 
-	while(</sys/bus/pci/devices/*>) {
+	while(<$Dahdi::sys_base/bus/pci/devices/*>) {
 		m,([^/]+)$,,;
 		my $name = $1;
 		my $l = readlink $_ || die;
diff --git a/xpp/perl_modules/Dahdi/Hardware/USB.pm b/xpp/perl_modules/Dahdi/Hardware/USB.pm
index 8b84243..711f977 100644
--- a/xpp/perl_modules/Dahdi/Hardware/USB.pm
+++ b/xpp/perl_modules/Dahdi/Hardware/USB.pm
@@ -135,7 +135,7 @@ sub scan_devices_sysfs($) {
 	my $pack = shift || die;
 	my @devices = ();
 
-	while (</sys/bus/usb/devices/*-*>) {
+	while (<$Dahdi::sys_base/bus/usb/devices/*-*>) {
 		next unless -r "$_/idVendor"; # endpoints
 
 		# Older kernels, e.g. 2.6.9, don't have the attribute
@@ -165,7 +165,7 @@ sub scan_devices_sysfs($) {
 
 sub scan_devices($) {
 	my $pack = shift || die;
-	my $usb_device_list = "/proc/bus/usb/devices";
+	my $usb_device_list = "$Dahdi::proc_usb_base/devices";
 	return $pack->scan_devices_sysfs() unless (-r $usb_device_list);
 
 	my @devices;
diff --git a/xpp/perl_modules/Dahdi/Span.pm b/xpp/perl_modules/Dahdi/Span.pm
index 943ab2b..9f4ca65 100644
--- a/xpp/perl_modules/Dahdi/Span.pm
+++ b/xpp/perl_modules/Dahdi/Span.pm
@@ -10,7 +10,6 @@ package Dahdi::Span;
 use strict;
 use Dahdi::Utils;
 use Dahdi::Chans;
-use Dahdi::Xpp::Xpd;
 
 =head1 NAME
 
@@ -113,8 +112,6 @@ actually set in the module as capital-letter propeties. To look at e.g.
 
 =cut
 
-my $proc_base = "/proc/dahdi";
-
 sub chans($) {
 	my $span = shift;
 	return @{$span->{CHANS}};
@@ -176,17 +173,13 @@ sub init_proto($$) {
 
 sub new($$) {
 	my $pack = shift or die "Wasn't called as a class method\n";
-	my $num = shift or die "Missing a span number parameter\n";
+	my $proc_file = shift or die "Missing a proc file parameter\n";
+	$proc_file =~ m{[^/]*/(\d+)$};
+	my $num = $1 or die " Invalid span file name: $proc_file\n";
 	my $self = { NUM => $num };
 	bless $self, $pack;
 	$self->{TYPE} = "UNKNOWN";
-	my @xpds = Dahdi::Xpp::Xpd::xpds_by_spanno;
-	my $xpd = $xpds[$num];
-	if(defined $xpd) {
-		die "Spanno mismatch: $xpd->spanno, $num" unless $xpd->spanno == $num;
-		$self->{XPD} = $xpd;
-	}
-	open(F, "$proc_base/$num") or die "Failed to open '$proc_base/$num\n";
+	open(F, "$proc_file") or die "Failed to open '$proc_file\n";
 	my $head = <F>;
 	chomp $head;
 	$self->{IS_DIGITAL} = 0;
diff --git a/xpp/perl_modules/Dahdi/Utils.pm b/xpp/perl_modules/Dahdi/Utils.pm
index dcb7441..4ca468b 100644
--- a/xpp/perl_modules/Dahdi/Utils.pm
+++ b/xpp/perl_modules/Dahdi/Utils.pm
@@ -23,6 +23,20 @@ sub AUTOLOAD {
 	}
 }
 
+# Initialize ProcFS and SysFS pathes, in case the user set
+# DAHDI_VIRT_TOP
+BEGIN {
+	if (exists $ENV{DAHDI_VIRT_TOP}) {
+		$Dahdi::virt_base = $ENV{DAHDI_VIRT_TOP};
+	} else {
+		$Dahdi::virt_base = '';
+	}
+	$Dahdi::proc_dahdi_base = "$Dahdi::virt_base/proc/dahdi";
+	$Dahdi::proc_xpp_base = "$Dahdi::virt_base/proc/xpp";
+	$Dahdi::proc_usb_base = "$Dahdi::virt_base/proc/bus/usb";
+	$Dahdi::sys_base = "$Dahdi::virt_base/sys";
+}
+
 sub xpp_dump($) {
 	my $self = shift || die;
 	printf STDERR "Dump a %s\n", ref($self);
diff --git a/xpp/perl_modules/Dahdi/Xpp.pm b/xpp/perl_modules/Dahdi/Xpp.pm
index 7ac574b..d4b315b 100644
--- a/xpp/perl_modules/Dahdi/Xpp.pm
+++ b/xpp/perl_modules/Dahdi/Xpp.pm
@@ -34,10 +34,16 @@ Dahdi::Xpp - Perl interface to the Xorcom Astribank drivers.
 #
 my @xbuses;
 
-my $proc_base = "/proc/xpp";
-our $sysfs_astribanks = "/sys/bus/astribanks/devices";
-our $sysfs_xpds = "/sys/bus/xpds/devices";
-our $sysfs_ab_driver = "/sys/bus/astribanks/drivers/xppdrv";
+our $sysfs_astribanks;
+our $sysfs_xpds;
+our $sysfs_ab_driver;
+
+BEGIN {
+	my $virt_base = $Dahdi::virt_base;
+	$sysfs_astribanks = "$virt_base/sys/bus/astribanks/devices";
+	$sysfs_xpds = "$virt_base/sys/bus/xpds/devices";
+	$sysfs_ab_driver = "$virt_base/sys/bus/astribanks/drivers/xppdrv";
+}
 
 sub scan($) {
 	my $pack = shift || die;
@@ -253,6 +259,7 @@ sub sync_via_proc {
 	my $result;
 	my $newapi = 0;
 
+	my $proc_base = $Dahdi::proc_xpp_base;
 	my $file = "$proc_base/sync";
 	return '' unless -f $file;
 	# First query
diff --git a/xpp/perl_modules/Dahdi/Xpp/Xbus.pm b/xpp/perl_modules/Dahdi/Xpp/Xbus.pm
index 4bc1844..b68d7cc 100644
--- a/xpp/perl_modules/Dahdi/Xpp/Xbus.pm
+++ b/xpp/perl_modules/Dahdi/Xpp/Xbus.pm
@@ -12,8 +12,6 @@ use Dahdi::Utils;
 use Dahdi::Hardware;
 use Dahdi::Xpp::Xpd;
 
-my $proc_base = "/proc/xpp";
-
 sub xpds($) {
 	my $xbus = shift;
 	return @{$xbus->{XPDS}};
@@ -54,7 +52,7 @@ sub xbus_attr_path($$) {
 	foreach my $attr (@attr) {
 		my $file = sprintf "$Dahdi::Xpp::sysfs_astribanks/xbus-%02d/$attr", $busnum;
 		unless(-f $file) {
-			my $procfile = sprintf "/proc/xpp/XBUS-%02d/$attr", $busnum;
+			my $procfile = sprintf "$Dahdi::proc_xpp_base/XBUS-%02d/$attr", $busnum;
 			warn "$0: warning - OLD DRIVER: missing '$file'. Fall back to '$procfile'\n"
 				unless $file_warned{$attr}++;
 			$file = $procfile;
@@ -113,7 +111,7 @@ sub transport_type($$) {
 
 sub read_xpdnames_old($) {
 	my $xbus_num = shift || die;
-	my $pat = sprintf "/proc/xpp/XBUS-%02d/XPD-[0-9][0-9]", $xbus_num;
+	my $pat = sprintf "$Dahdi::proc_xpp_base/XBUS-%02d/XPD-[0-9][0-9]", $xbus_num;
 	my @xpdnames;
 
 	#print STDERR "read_xpdnames_old($xbus_num): $pat\n";
@@ -175,7 +173,7 @@ sub new($$) {
 	}
 	foreach my $xpdstr (@xpdnames) {
 		my ($busnum, $unit, $subunit) = split(/:/, $xpdstr);
-		my $procdir = "/proc/xpp/XBUS-$busnum/XPD-$unit$subunit";
+		my $procdir = "$Dahdi::proc_xpp_base/XBUS-$busnum/XPD-$unit$subunit";
 		my $xpd = Dahdi::Xpp::Xpd->new($self, $unit, $subunit, $procdir, "$xbus_dir/$xpdstr");
 		push(@xpds, $xpd);
 	}