make/directive.pm

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