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
|
