make/directive.pm

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