File: XawWrapper.pm

package info (click to toggle)
xaw-wrappers 0.23
  • links: PTS
  • area: main
  • in suites: slink
  • size: 72 kB
  • ctags: 14
  • sloc: perl: 237; makefile: 35; sh: 31
file content (123 lines) | stat: -rw-r--r-- 3,403 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
#!/usr/bin/perl
#
# This a a config file parsing module for the xaw-wrapper package.
#
# When the package is loaded, all config files are read, and the info from 
# them is stored in $XawWrapper::files
#
# TODO: document the $files hash structure.
#
# GPL copyright by Joey Hess <joeyh@master.debian.org>.

package XawWrapper;

# When this module is loaded, all config files are automatically read.
sub import {
	ReadConfig("/usr/lib/xaw-wrappers/conf/");
	ReadConfigFile("/etc/X11/xaw-wrappers.conf",1); # not fatal if not found.
}

# Read in a configuration file.
#
# If the second parameter (optional) is true, then it is not fatal
# for the config file to exist.
#
# The config files have 2 fields: filename, and incompatable library.
# The fields are separated by commas. Standard hash-mark quotes may be used.
sub ReadConfigFile { ($fn,$notfatal)=@_;
	open (CONFIG,"<$fn") || $notfatal || die "open $fn: $!\n";
	while (<CONFIG>) {
		chomp;
		if ($_ and /^#/ eq undef) {
			my ($filename,$incompat)=split(/,/,$_,2);
			chomp $incompat, "/"; # remove trailing / character, if any.
			if ($incompat ne "NONE") {
				$files{$filename}{$incompat}=1;
			}
			else {
				# Delete all previous incompatabilities.
				delete $files{$filename};
			}
		}
	}
	close CONFIG;
}

# Read in all config files in the passed config directory.
sub ReadConfig { my $config_dir=shift;
	opendir (CONFIGDIR,"$config_dir") || die "opendir $config_dir: $!\n";
	while ($fn=readdir(CONFIGDIR)) {
		if (!-d $fn) {		
			ReadConfigFile($config_dir.'/'.$fn);
		}
	}
	closedir CONFIGDIR;
}

# Passed a filename, find all directories in it that are sylinkes, and replace 
# with the real directory names. Calls itself recursivly until no more symlinks
# are left in the filename.
# Note that the path this returns may be ugly and have lots of extra /'s and
# ..'s and .'s in it. Use GetAbsolutePath to clean it up. Also note that this 
# only works if it's passed an absulte path to begin with. Therefore, a 
# typical invocation will be something like:
# GetAbsolutePath(DeSymlinkPath(GetAbsolutePath(file)))
sub DeSymlinkPath { $_=shift;
	my $dirty=undef; # set to 1 if we encounter a symlink.
	my @dirlist=split(m:/:, $_);
	$fn=pop(@dirlist); # don't check the actual file to see if it's a link.

	my $pwd=undef;
	foreach $dir (@dirlist) {
		if (-l "$pwd/$dir") {
			$dirty=1;
			$dir=readlink("$pwd/$dir");
			if ($dir=~m:^/: eq undef) { # relative symlink, add to current pwd.
				$pwd="$pwd/$dir";
			}
			else { # absolute symlink, replaces current pwd.
				$pwd=$dir;
			}
		}
		else { # normal directory, add to pwd.
			$pwd="$pwd/$dir";
		}
	}

	if ($dirty) {
		return DeSymlinkPath("$pwd/$fn");
	}
	else {
		return "$pwd/$fn";
	}
}

# Passed a filname that may be relative, determine the absolute filename. 
# So we have to get rid of relative pathnames, and we even have to handle 
# things like ./../../../usr/X11R5/../X11R6/bin/./foo
sub GetAbsolutePath { $_=shift;
	if (m:^/: eq undef) { # doesn't start with / , so is a relative path.
		my $pwd=`pwd`; # isn't there a perl function for this?
		chomp $pwd;
		$_="$pwd/$_";
	}

	tr:/:/:s; # replace all // with /

	my @dirlist;
	foreach $dir (split(m:/:, $_)) {
		if ($dir eq '..') {
			pop @dirlist; # go down 1 directory.
		}
		elsif ($dir ne '.') {
			push (@dirlist,$dir);
		}
	}

	$_='/'. join('/',@dirlist);
	tr:/:/:s; # replace all // with /

	return $_;
}

1