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
124
125
126
127
128
129
130
|
#
# InspIRCd -- Internet Relay Chat Daemon
#
# Copyright (C) 2016-2025 Sadie Powell <sadie@witchery.services>
#
# This file is part of InspIRCd. InspIRCd is free software: you can
# redistribute it and/or modify it under the terms of the GNU General Public
# License as published by the Free Software Foundation, version 2.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
#
package make::directive;
use v5.26.0;
use strict;
use warnings FATAL => qw(all);
use File::Basename qw(dirname);
use File::Spec::Functions qw(catdir);
use Exporter qw(import);
use make::common;
use make::console;
use constant DIRECTIVE_ERROR_PIPE => $ENV{INSPIRCD_VERBOSE} ? '' : '2>/dev/null';
our @EXPORT = qw(
get_directives
get_directive
execute_functions
);
sub get_directives($$;$) {
my ($file, $property, $functions) = @_;
$functions //= 1;
open(my $fh, $file) or return ();
my @values;
while (<$fh>) {
if ($_ =~ /^\/\* \$(\S+): (.+) \*\/$/ || $_ =~ /^\/\/\/ \$(\S+): (.+)/) {
next unless $1 eq $property;
my $value = $functions ? execute_functions($file, $1, $2) : $2;
push @values, $value;
}
}
close $fh;
return @values;
}
sub get_directive($$;$$) {
my ($file, $property, $default, $functions) = @_;
my @values = get_directives($file, $property, $functions);
my $value = join ' ', @values;
$value =~ s/^\s+|\s+$//g;
return $value || $default;
}
sub execute_functions($$$) {
my ($file, $name, $line) = @_;
# NOTE: we have to use 'our' instead of 'my' here because of a Perl bug.
for (our @parameters = (); $line =~ /([a-z_]+)\((?:\s*"([^"]*)(?{push @parameters, $2})"\s*)*\)/; undef @parameters) {
my $sub = make::directive->can("__function_$1");
print_error "unknown $name function '$1' in $file!" unless $sub;
# Call the subroutine and replace the function.
my $result = $sub->($file, @parameters);
if (defined $result) {
$line = $` . $result . $';
next;
}
# If the subroutine returns undef then it is a sign that we should
# disregard the rest of the line and stop processing it.
$line = $`;
}
return $line;
}
sub __function_require_system {
my ($file, $name, $minimum, $maximum) = @_;
my ($system, $system_like, $version);
# Check for an inverted match.
my ($ok, $err) = ("", undef);
if ($name =~ s/^!//) {
($ok, $err) = ($err, $ok);
}
# If a system name ends in a tilde we match on alternate names.
my $match_like = $name =~ s/~$//;
# Linux is special and can be compared by distribution names.
if ($^O eq 'linux' && $name ne 'linux') {
chomp($system = lc `sh -c '. /etc/os-release 2>/dev/null && echo \$ID'`);
chomp($system_like = lc `sh -c '. /etc/os-release 2>/dev/null && echo \$ID_LIKE'`);
chomp($version = lc `sh -c '. /etc/os-release 2>/dev/null && echo \$VERSION_ID'`);
}
# Gather information on the system if we don't have it already.
chomp($system ||= lc `uname -s 2>/dev/null`);
chomp($version ||= lc `uname -r 2>/dev/null`);
$system_like ||= '';
# We only care about the important bit of the version number so trim the rest.
$version =~ s/^(\d+\.\d+).+/$1/;
# Check whether the current system is suitable.
if ($name ne $system) {
return $err unless $match_like;
return $err unless grep { $_ eq $name } split /\s+/, $system_like;
}
return $err if defined $minimum && $version < $minimum;
return $err if defined $maximum && $version > $maximum;
# Requirement directives don't change anything directly.
return $ok;
}
1;
|
