make/directive.pm

   1 #
   2 # InspIRCd -- Internet Relay Chat Daemon
   3 #
   4 #   Copyright (C) 2016-2021 Sadie Powell <sadie@witchery.services>
   5 #
   6 # This file is part of InspIRCd.  InspIRCd is free software: you can
   7 # redistribute it and/or modify it under the terms of the GNU General Public
   8 # License as published by the Free Software Foundation, version 2.
   9 #
  10 # This program is distributed in the hope that it will be useful, but WITHOUT
  11 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  12 # FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  13 # details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17 #
  18
  19
  20 package make::directive;
  21
  22 use v5.10.0;
  23 use strict;
  24 use warnings FATAL => qw(all);
  25
  26 use File::Basename        qw(dirname);
  27 use File::Spec::Functions qw(catdir);
  28 use Exporter              qw(import);
  29
  30 use make::configure;
  31 use make::console;
  32
  33 use constant DIRECTIVE_ERROR_PIPE => $ENV{INSPIRCD_VERBOSE} ? '' : '2>/dev/null';
  34 use constant VENDOR_DIRECTORY     => catdir(dirname(dirname(__FILE__)), 'vendor');
  35
  36 our @EXPORT = qw(get_directive
  37                  execute_functions);
  38
  39 sub get_directive($$;$)
  40 {
  41         my ($file, $property, $default) = @_;
  42         open(my $fh, $file) or return $default;
  43
  44         my $value = '';
  45         while (<$fh>) {
  46                 if ($_ =~ /^\/\* \$(\S+): (.+) \*\/$/ || $_ =~ /^\/\/\/ \$(\S+): (.+)/) {
  47                         next unless $1 eq $property;
  48                         $value .= ' ' . execute_functions($file, $1, $2);
  49                 }
  50         }
  51         close $fh;
  52
  53         # Strip all extraneous whitespace.
  54         $value =~ s/^\s+|\s+$//g;
  55         return $value || $default;
  56 }
  57
  58 sub execute_functions($$$) {
  59         my ($file, $name, $line) = @_;
  60
  61         # NOTE: we have to use 'our' instead of 'my' here because of a Perl bug.
  62         for (our @parameters = (); $line =~ /([a-z_]+)\((?:\s*"([^"]*)(?{push @parameters, $2})"\s*)*\)/; undef @parameters) {
  63                 my $sub = make::directive->can("__function_$1");
  64                 print_error "unknown $name directive '$1' in $file!" unless $sub;
  65
  66                 # Call the subroutine and replace the function.
  67                 my $result = $sub->($file, @parameters);
  68                 if (defined $result) {
  69                         $line = $` . $result . $';
  70                         next;
  71                 }
  72
  73                 # If the subroutine returns undef then it is a sign that we should
  74                 # disregard the rest of the line and stop processing it.
  75                 $line = $`;
  76         }
  77
  78         return $line;
  79 }
  80
  81 sub __environment {
  82         my ($prefix, $suffix) = @_;
  83         $suffix =~ s/[-.]/_/g;
  84         $suffix =~ s/[^A-Za-z0-9_]//g;
  85         return $prefix . uc $suffix;
  86 }
  87
  88 sub __error {
  89         my ($file, @message) = @_;
  90         push @message, '';
  91
  92         # If we have package details then suggest to the user that they check
  93         # that they have the packages installed.=
  94         my $dependencies = get_directive($file, 'PackageInfo');
  95         if (defined $dependencies) {
  96                 my @packages = sort grep { /^\S+$/ } split /\s/, $dependencies;
  97                 push @message, 'You should make sure you have the following packages installed:';
  98                 for (@packages) {
  99                         push @message, " * $_";
 100                 }
 101         } else {
 102                 push @message, 'You should make sure that you have all of the required dependencies';
 103                 push @message, 'for this module installed.';
 104         }
 105         push @message, '';
 106
 107         # If we have author information then tell the user to report the bug
 108         # to them. Otherwise, assume it is a bundled module and tell the user
 109         # to report it to the InspIRCd issue tracker.
 110         my $author = get_directive($file, 'ModAuthor');
 111         if (defined $author) {
 112                 push @message, 'If you believe this error to be a bug then you can try to contact the';
 113                 push @message, 'author of this module:';
 114                 my $author_mail = get_directive($file, 'ModAuthorMail');
 115                 if (defined $author_mail) {
 116                         push @message, " * $author <$author_mail>";
 117                 } else {
 118                         push @message, " * $author";
 119                 }
 120         } else {
 121                 push @message, 'If you believe this error to be a bug then you can file a bug report';
 122                 push @message, 'at https://github.com/inspircd/inspircd/issues';
 123                 push @message, '';
 124                 push @message, 'You can also refer to the documentation page for this module at';
 125                 push @message, "https://docs.inspircd.org/3/modules/${\module_shrink $file}";
 126         }
 127         push @message, '';
 128
 129         push @message, 'If you would like help with fixing this problem then visit our IRC';
 130         push @message, 'channel at irc.inspircd.org #InspIRCd or create a support discussion';
 131         push @message, 'at https://github.com/inspircd/inspircd/discussions.';
 132         push @message, '';
 133
 134         print_error @message;
 135 }
 136
 137 sub __function_error {
 138         my ($file, @messages) = @_;
 139         __error $file, @messages;
 140 }
 141
 142 sub __function_execute {
 143         my ($file, $command, $environment, $defaults) = @_;
 144
 145         # Try to execute the command...
 146         chomp(my $result = `$command ${\DIRECTIVE_ERROR_PIPE}`);
 147         unless ($?) {
 148                 say console_format "Execution of `<|GREEN $command|>` succeeded: <|BOLD $result|>";
 149                 return $result;
 150         }
 151
 152         # If looking up with pkg-config fails then check the environment...
 153         if (defined $environment && $environment ne '') {
 154                 $environment = __environment 'INSPIRCD_', $environment;
 155                 if (defined $ENV{$environment}) {
 156                         say console_format "Execution of `<|GREEN $command|>` failed; using the environment: <|BOLD $ENV{$environment}|>";
 157                         return $ENV{$environment};
 158                 }
 159         }
 160
 161         # If all else fails then look for the defaults..
 162         if (defined $defaults) {
 163                 say console_format "Execution of `<|GREEN $command|>` failed; using the defaults: <|BOLD $defaults|>";
 164                 return $defaults;
 165         }
 166
 167         # Executing the command failed and we don't have any defaults so give up.
 168         __error $file, "`<|GREEN $command|>` exited with a non-zero exit code!";
 169 }
 170
 171 sub __function_find_compiler_flags {
 172         my ($file, $name, $defaults) = @_;
 173
 174         # Try to look up the compiler flags with pkg-config...
 175         chomp(my $flags = `pkg-config --cflags $name ${\DIRECTIVE_ERROR_PIPE}`);
 176         unless ($?) {
 177                 say console_format "Found the <|GREEN $name|> compiler flags for <|GREEN ${\module_shrink $file}|> using pkg-config: <|BOLD $flags|>";
 178                 return $flags;
 179         }
 180
 181         # If looking up with pkg-config fails then check the environment...
 182         my $key = __environment 'INSPIRCD_CXXFLAGS_', $name;
 183         if (defined $ENV{$key}) {
 184                 say console_format "Found the <|GREEN $name|> compiler flags for <|GREEN ${\module_shrink $file}|> using the environment: <|BOLD $ENV{$key}|>";
 185                 return $ENV{$key};
 186         }
 187
 188         # If all else fails then look for the defaults..
 189         if (defined $defaults) {
 190                 say console_format "Using the default <|GREEN $name|> compiler flags for <|GREEN ${\module_shrink $file}|>: <|BOLD $defaults|>";
 191                 return $defaults;
 192         }
 193
 194         # We can't find it via pkg-config, via the environment, or via the defaults so give up.
 195         __error $file, "unable to find the <|GREEN $name|> compiler flags for <|GREEN ${\module_shrink $file}|>!";
 196 }
 197
 198 sub __function_find_linker_flags {
 199         my ($file, $name, $defaults) = @_;
 200
 201         # Try to look up the linker flags with pkg-config...
 202         chomp(my $flags = `pkg-config --libs $name ${\DIRECTIVE_ERROR_PIPE}`);
 203         unless ($?) {
 204                 say console_format "Found the <|GREEN $name|> linker flags for <|GREEN ${\module_shrink $file}|> using pkg-config: <|BOLD $flags|>";
 205                 return $flags;
 206         }
 207
 208         # If looking up with pkg-config fails then check the environment...
 209         my $key = __environment 'INSPIRCD_CXXFLAGS_', $name;
 210         if (defined $ENV{$key}) {
 211                 say console_format "Found the <|GREEN $name|> linker flags for <|GREEN ${\module_shrink $file}|> using the environment: <|BOLD $ENV{$key}|>";
 212                 return $ENV{$key};
 213         }
 214
 215         # If all else fails then look for the defaults..
 216         if (defined $defaults) {
 217                 say console_format "Using the default <|GREEN $name|> linker flags for <|GREEN ${\module_shrink $file}|>: <|BOLD $defaults|>";
 218                 return $defaults;
 219         }
 220
 221         # We can't find it via pkg-config, via the environment, or via the defaults so give up.
 222         __error $file, "unable to find the <|GREEN $name|> linker flags for <|GREEN ${\module_shrink $file}|>!";
 223 }
 224
 225 sub __function_require_compiler {
 226         my ($file, $name, $minimum, $maximum) =  @_;
 227
 228         # Look up information about the compiler.
 229         return undef unless $ENV{CXX};
 230         my %compiler = get_compiler_info($ENV{CXX});
 231
 232         # Check whether the current compiler is suitable.
 233         return undef unless $compiler{NAME} eq $name;
 234         return undef if defined $minimum && $compiler{VERSION} < $minimum;
 235         return undef if defined $maximum && $compiler{VERSION} > $maximum;
 236
 237         # Requirement directives don't change anything directly.
 238         return "";
 239 }
 240
 241 sub __function_require_system {
 242         my ($file, $name, $minimum, $maximum) = @_;
 243         my ($system, $version);
 244
 245         # Linux is special and can be compared by distribution names.
 246         if ($^O eq 'linux' && $name ne 'linux') {
 247                 chomp($system = lc `lsb_release --id --short 2>/dev/null`);
 248                 chomp($version = lc `lsb_release --release --short 2>/dev/null`);
 249         }
 250
 251         # Gather information on the system if we don't have it already.
 252         chomp($system ||= lc `uname -s 2>/dev/null`);
 253         chomp($version ||= lc `uname -r 2>/dev/null`);
 254
 255         # We only care about the important bit of the version number so trim the rest.
 256         $version =~ s/^(\d+\.\d+).+/$1/;
 257
 258         # Check whether the current system is suitable.
 259         return undef if $name ne $system;
 260         return undef if defined $minimum && $version < $minimum;
 261         return undef if defined $maximum && $version > $maximum;
 262
 263         # Requirement directives don't change anything directly.
 264         return "";
 265 }
 266
 267 sub __function_require_version {
 268         my ($file, $name, $minimum, $maximum) = @_;
 269
 270         # If pkg-config isn't installed then we can't do anything here.
 271         if (system "pkg-config --exists $name ${\DIRECTIVE_ERROR_PIPE}") {
 272                 print_warning "unable to look up the version of <|GREEN $name|> using pkg-config!";
 273                 return undef;
 274         }
 275
 276         # Check with pkg-config whether we have the required version.
 277         return undef if defined $minimum && system "pkg-config --atleast-version $minimum $name";
 278         return undef if defined $maximum && system "pkg-config --max-version $maximum $name";
 279
 280         # Requirement directives don't change anything directly.
 281         return "";
 282 }
 283
 284 sub __function_vendor_directory {
 285         my ($file, $name) = @_;
 286
 287         # Try to look the directory up in the environment...
 288         my $key = __environment 'INSPIRCD_VENDOR_', $name;
 289         if (defined $ENV{$key}) {
 290                 say console_format "Found the <|GREEN $name|> vendor directory for <|GREEN ${\module_shrink $file}|> using the environment: <|BOLD $ENV{$key}|>";
 291                 return $ENV{$key};
 292         }
 293
 294         my $directory = catdir(VENDOR_DIRECTORY, $name);
 295         if (-d $directory) {
 296                 say console_format "Using the default <|GREEN $name|> vendor directory for <|GREEN ${\module_shrink $file}|>: <|BOLD $directory|>";
 297                 return $directory;
 298         }
 299
 300         # We can't find it via the environment or via the filesystem so give up.
 301         __error $file, "unable to find the <|GREEN $name|> vendor directory for <|GREEN ${\module_shrink $file}|>!";
 302 }
 303
 304 sub __function_warning {
 305         my ($file, @messages) = @_;
 306         print_warning @messages;
 307 }
 308
 309 1;