pkgsrc-Changes archive
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index][Old Index]
CVS commit: pkgsrc/lang/nqp/files
Module Name: pkgsrc
Committed By: mef
Date: Wed Mar 12 11:27:43 UTC 2025
Added Files:
pkgsrc/lang/nqp/files: Config.pm Macros.pm
Log Message:
(lang/nqp) Add two files, missed at last update
To generate a diff of this commit:
cvs rdiff -u -r0 -r1.1 pkgsrc/lang/nqp/files/Config.pm \
pkgsrc/lang/nqp/files/Macros.pm
Please note that diffs are not public domain; they are subject to the
copyright notices on the relevant files.
Added files:
Index: pkgsrc/lang/nqp/files/Config.pm
diff -u /dev/null pkgsrc/lang/nqp/files/Config.pm:1.1
--- /dev/null Wed Mar 12 11:27:43 2025
+++ pkgsrc/lang/nqp/files/Config.pm Wed Mar 12 11:27:43 2025
@@ -0,0 +1,1635 @@
+use v5.10.1;
+
+package NQP::Config::_Scoping;
+
+sub new {
+ my $class = shift;
+ my $cb = shift;
+ my %params = @_;
+ my $self = bless {}, $class;
+ $self->{cb} = $cb;
+ $self->{params} = \%params;
+ return $self;
+}
+
+sub DESTROY {
+ my $self = shift;
+ $self->{cb}->( %{ $self->{params} } );
+}
+
+package NQP::Config;
+use strict;
+use warnings;
+use File::Spec;
+use File::Spec::Unix;
+use File::Basename;
+use FindBin;
+use Data::Dumper;
+use NQP::Macros;
+use IPC::Cmd qw<can_run run run_forked>;
+use Cwd;
+use Carp;
+use ExtUtils::Command;
+
+$SIG{__DIE__} = sub { confess @_ };
+
+use base qw<Exporter>;
+our @EXPORT = qw<rm_l>;
+our @EXPORT_OK = qw<
+ os2platform slash slurp system_or_die run_or_die cmp_rev read_config read_config_from_command
+>;
+
+# Platform names will be incorporated into a regexp.
+# unix will be used as the last resort option and thus will always be tested
+# last.
+my %os_platforms = (
+ 'windows' => [qw<MSWin32 os2>],
+ 'vms' => [qw<VMS>],
+ 'unix' => [qw<.*>],
+);
+
+my %platform_vars = (
+ bat => {
+ windows => '.bat',
+ default => '',
+ },
+ exe => {
+ windows => '.exe',
+ default => '',
+ },
+ cpsep => {
+ windows => ';',
+ default => ':',
+ },
+ tab => {
+ default => "\t",
+ },
+ env_open => {
+ windows => '%',
+ vms => '%%',
+ unix => '$',
+ },
+ env_close => {
+ windows => '%',
+ vms => '%%',
+ unix => '',
+ },
+ quote => {
+ windows => q<">,
+ default => q<'>,
+ },
+ shebang => {
+ windows => qq<\n>,
+ default => qq<#!/bin/sh\n>,
+ },
+ sh_allparams => { # All command line params
+ windows => q<%*>,
+ default => q<$@>,
+ },
+);
+
+sub new {
+ my $self = shift;
+ my $class = ref($self) || $self;
+
+ if ( $class eq __PACKAGE__ ) {
+ die "Can't create instance of class " . $class
+ . ", use a language sub-class instead";
+ }
+
+ my $new_obj = bless { config => {}, }, $class;
+ $new_obj->init(@_);
+ return $new_obj;
+}
+
+sub init {
+ my $self = shift;
+ my %params = @_;
+
+ my $config = $self->{config};
+
+ $self->{quiet} = 0;
+
+ $self->configure_platform;
+
+ my $lang = $params{lang} // ( split /::/, ref($self) )[-1];
+
+ $config->{perl} = $^X;
+ $config->{slash} = slash();
+ $config->{shell} = $^O eq 'solaris' ? '' : "SHELL = " . $self->shell_cmd;
+ $config->{lang} = $lang;
+ $config->{lclang} = lc $lang;
+
+ # Num of spaces to indent lists in the Makefile
+ $config->{list_indent} =
+ $config->{filelist_indent} = 4;
+
+ $self->{backend_prefix} = {
+ moar => 'm',
+ jvm => 'j',
+ js => 'js',
+ };
+
+ # Precompiled files extensions
+ $self->{backend_ext} = {
+ moar => 'moarvm',
+ jvm => 'jar',
+ js => 'js',
+ };
+
+ # Value of nqp --target
+ $self->{backend_target} = {
+ moar => 'mbc',
+ jvm => 'jar',
+ js => 'js',
+ };
+ $self->{backends_order} = [qw<moar jvm js>];
+ $self->{options} = {
+ 'silent-build' => 1,
+ 'clean' => 1,
+ };
+ $self->{contexts} = [];
+ $self->{repo_maps} = {
+ rakudo => [qw<rakudo rakudo>],
+ nqp => [qw<Raku nqp>],
+ moar => [qw<MoarVM MoarVM>],
+ roast => [qw<Raku roast>],
+ };
+
+ $self->{impls} = {};
+ for my $be ( @{ $self->{backends_order} } ) {
+ $self->backend_config( $be, {} );
+ }
+
+ return $self;
+}
+
+sub msg {
+ my $self = shift;
+ return if $self->{quiet};
+ print @_;
+}
+
+sub mute {
+ my $self = shift;
+ $self->{quiet} = @_ ? !!shift : 1;
+}
+
+sub _gen_msg {
+ my $self = shift;
+ my $type = shift;
+ my @msg = (
+ "===$type===\n",
+ join( "\n", map { " $_" } split /\n/s, join( "", @_ ) )
+ );
+ return wantarray ? @msg : join( "", @msg );
+}
+
+sub sorry {
+ my $self = shift;
+ my (@msg) = @_;
+ my $message = $self->_gen_msg( 'SORRY!', join( "\n", @msg ), "\n" );
+ die $message unless $self->option('ignore-errors');
+ print $message;
+}
+
+# Output a note-kind of message:
+# ===TYPE===\n
+# Text
+sub note {
+ my $self = shift;
+ say $self->_gen_msg(@_);
+}
+
+sub shell_cmd {
+ $_[0]->is_win ? 'cmd' : 'sh';
+}
+
+sub batch_file {
+ my $self = shift;
+ my $source = shift;
+ my ( $vol, $dir, $file ) = File::Spec->splitpath($source);
+ my $basename = basename( $file, "." . $self->cfg('bat') );
+ return File::Spec->catpath( $vol, $dir, "$basename" . $self->cfg('bat') );
+}
+
+sub make_cmd {
+ my $self = shift;
+
+ my $config = $self->{config};
+
+ my $make = 'make';
+ if ( $self->is_solaris ) {
+ $make = can_run('gmake');
+ unless ($make) {
+ die
+"gmake is required to compile rakudo. Please install by 'pkg install gnu-make'";
+ }
+ $make = 'gmake';
+ }
+
+ if ( $self->is_bsd ) {
+ $make = can_run('gmake');
+ unless ($make) {
+
+ # TODO Make sure it is BSD make by trying BSDmakefile
+ $make = 'make';
+ }
+ }
+
+ if ( $self->is_win ) {
+ my $prefix = $config->{prefix};
+ my $has_nmake = 0 == system('nmake /? >NUL 2>&1');
+ my $cl_report;
+ my $has_cl = can_run('cl')
+ && ( $cl_report = `cl 2>&1` ) =~ /Microsoft Corporation/;
+ my $has_gmake = 0 == system('gmake --version >NUL 2>&1');
+ my $has_gcc = 0 == system('gcc --version >NUL 2>&1');
+ if ($has_cl) {
+ if ( $cl_report =~
+ /Microsoft\s.*\sCompiler\s+Version\s+(\d+(?:\.\d+)+)/i )
+ {
+ my $actual_version = $1;
+ my $expect_version = "19.0";
+ if ( version->parse($actual_version) < $expect_version ) {
+ $self->sorry( "Expected Microsoft Compiler version "
+ . $expect_version
+ . "+, but got "
+ . $actual_version );
+ }
+ }
+ }
+ if (
+ -x "$prefix\\bin\\nqp-m.exe"
+ && ( $_ =
+`"$prefix\\bin\\nqp-m.exe" -e "print(nqp::backendconfig()<make>)"`
+ )
+ )
+ {
+ $make = $_;
+ }
+ elsif (
+ -x "$prefix\\bin\\nqp-m.bat"
+ && ( $_ =
+`"$prefix\\bin\\nqp-m.bat" -e "print(nqp::backendconfig()<make>)"`
+ )
+ )
+ {
+ $make = $_;
+ }
+ elsif ( $has_nmake && $has_cl ) {
+ $make = 'nmake';
+ }
+ elsif ( $has_gmake && $has_gcc ) {
+ $make = 'gmake';
+ }
+ }
+ return $make;
+}
+
+sub options {
+ $_[0]->{options};
+}
+
+sub option {
+ die "Option name required for option method" unless @_ > 1;
+ $_[0]->{options}{ $_[1] };
+}
+
+*opt = *option;
+
+sub has_option {
+ die "Option name required for has_option method" unless @_ > 1;
+ exists $_[0]->{options}{ $_[1] };
+}
+
+sub validate_backend {
+ my ( $self, $backend, $method ) = @_;
+ $self->sorry( "Unknown backend '$backend'"
+ . ( $method ? " in a call to method '$method'" : "" ) )
+ unless $self->known_backend($backend);
+ return $backend;
+}
+
+sub known_backends {
+ my $self = shift;
+ return @{ $self->{backends_order} };
+}
+
+sub known_backend {
+ return exists $_[0]->{backend_prefix}{ $_[1] };
+}
+
+sub abbr_to_backend {
+ my ( $self, $abbr ) = @_;
+ unless ( $self->{abbr_to_backend} ) {
+ for my $backend ( $self->known_backends ) {
+ $self->{abbr_to_backend}{ $self->{backend_prefix}{$backend} } =
+ $backend;
+ }
+ }
+ die "Unknown backend abbreviation '$abbr' in call to abbr_to_backend"
+ unless $self->{abbr_to_backend}{$abbr};
+ return $self->{abbr_to_backend}{$abbr};
+}
+
+sub backend_abbr {
+ my ( $self, $backend ) = @_;
+ return $self->{backend_prefix}{ $self->validate_backend($backend) };
+}
+
+sub backend_ext {
+ my ( $self, $backend ) = @_;
+ return $self->{backend_ext}{ $self->validate_backend($backend) };
+}
+
+sub backend_target {
+ my ( $self, $backend ) = @_;
+ return $self->{backend_target}{ $self->validate_backend($backend) };
+}
+
+sub backend_config {
+ my ( $self, $backend ) = ( shift, shift );
+ if (@_) {
+ my %config;
+ if ( @_ == 1 && ref( $_[0] ) eq 'HASH' ) {
+ %config = %{ $_[0] };
+ }
+ elsif ( @_ % 2 == 0 ) {
+ %config = @_;
+ }
+ else {
+ die "Bad configuration hash passed in to backend_config";
+ }
+ @{ $self->{impls}{$backend}{config} }{ keys %config } =
+ values %config;
+ }
+ return $self->{impls}{$backend}{config};
+}
+
+sub known_abbrs {
+ return values %{ $_[0]->{backend_prefix} };
+}
+
+sub use_backend {
+ my ( $self, $backend ) = @_;
+ return if $self->active_backend($backend);
+ push @{ $self->{active_backends_order} }, $backend;
+ $self->{active_backends}{ $self->validate_backend($backend) } = 1;
+ $self->{config}{default_backend} ||= $backend;
+ $self->{config}{default_prefix} ||= $self->backend_abbr($backend);
+}
+
+sub active_backends {
+ my $self = shift;
+ return () unless $self->{active_backends_order};
+ return @{ $self->{active_backends_order} };
+}
+
+sub active_backend {
+ my ( $self, $backend ) = @_;
+ return !!$self->{active_backends}{ $self->validate_backend($backend) };
+}
+
+sub active_abbrs {
+ my $self = shift;
+ return map { $self->backend_abbr($_) } $self->active_backends;
+}
+
+# Takes a relative path
+sub base_path {
+ my $self = shift;
+ my @rel_path = @_;
+
+ if ( @rel_path == 1 ) {
+ return $rel_path[0]
+ if File::Spec->file_name_is_absolute( $rel_path[0] );
+ @rel_path = File::Spec->splitdir( $rel_path[0] );
+ }
+
+ return File::Spec->catfile( $self->{config}{base_dir}, @rel_path );
+}
+
+# This one is called by init
+sub configure_platform {
+ my $self = shift;
+ my $config = $self->{config};
+
+ $config->{OS} //= $^O;
+ $config->{platform} = os2platform( $config->{OS} );
+
+ for my $var ( keys %platform_vars ) {
+ my $val =
+ $platform_vars{$var}{ $config->{platform} }
+ // $platform_vars{$var}{default} // die(
+ "Config variable '$var' is not defined for $config->{platform}");
+ $config->{$var} = $val;
+ }
+}
+
+sub configure_paths {
+ my $self = shift;
+ my $config = $self->{config};
+
+ my $base_dir = $self->nfp($FindBin::Bin);
+
+ $config->{base_dir} = $base_dir;
+ $config->{build_dir} = File::Spec->catdir( $base_dir, 'tools', 'build' );
+ $config->{templates_dir} =
+ File::Spec->catdir( $base_dir, 'tools', 'templates' );
+ $config->{configure_script} = File::Spec->canonpath(
+ File::Spec->catfile( $base_dir, $FindBin::Script ) );
+}
+
+sub configure_jars {
+ my $self = shift;
+ my $jars = shift;
+
+ my $config = $self->{config};
+ my $options = $self->{options};
+
+ foreach my $name ( keys %$jars ) {
+ my $path = $jars->{$name};
+ my $variable = $name;
+ $variable =~ s/-//;
+ if ( $options->{"with-$name"} ) {
+ if ( $options->{"with-$name"} ne '-' ) {
+ $config->{$variable} = $options->{"with-$name"};
+ }
+ }
+ else {
+ $config->{$variable} = $self->base_path( @{$path} );
+ }
+
+ $config->{ $variable . 'file' } =
+ ( File::Spec->splitpath( $config->{$variable} ) )[-1];
+ }
+}
+
+sub configure_relocatability {
+ my $self = shift;
+
+ # Relocatability is not supported on AIX and OpenBSD.
+ if ( $^O =~ /^(?:aix|openbsd)$/ && $self->{options}->{relocatable} ) {
+ $self->sorry( 'Relocatability is not supported on '
+ . $^O
+ . ".\nLeave off the --relocatable flag to do a non-relocatable build."
+ );
+ }
+
+ if (
+ $self->{options}->{relocatable}
+ && ( $self->{options}->{'rakudo-home'}
+ || $self->{options}->{'nqp-home'} )
+ )
+ {
+ $self->sorry(
+"It's not possible to build a relocatable rakudo and use hard coded rakudo-home"
+ . "\nor nqp-home directories. So either don't use the `--relocatable` parameter or don't"
+ . "\nuse the `--perl6-home`, `--rakudo-home`, and `--nqp-home` parameters."
+ );
+ }
+
+ $self->{config}->{relocatable} =
+ $self->{options}->{relocatable} ? 'reloc' : 'nonreloc';
+}
+
+# This would prepare git URL config variables for default protocol.
+sub configure_repo_urls {
+ my $self = shift;
+
+ # Pre-cache repo urls to make them available for makefiles.
+ for my $r ( keys %{ $self->{repo_maps} } ) {
+ $self->repo_url( $r, action => 'pull' );
+ $self->repo_url( $r, action => 'push' );
+ }
+}
+
+sub configure_commands {
+ my $self = shift;
+ my $config = $self->{config};
+
+ $config->{make} = $self->make_cmd;
+
+ my $buf;
+ for (my $retries = 50; $retries; $retries--) {
+ my $ok = run( command => [ $config->{make}, q<-v> ], buffer => \$buf );
+ unless ($ok) {
+ $ok = run( command => [ $config->{make}, q</?> ], buffer => \$buf );
+ }
+ if ( $buf =~ /^GNU Make/s ) {
+ $config->{make_family} = 'gnu';
+ $config->{make_first_prereq} = '$<';
+ $config->{make_all_prereq} = '$^';
+ $config->{make_pp_pfx} = ''; # make preprocessor directive prefix
+ }
+ elsif ( $buf =~ /Microsoft/s ) {
+ $config->{make_family} = 'nmake';
+ $config->{make_first_prereq} = '%s';
+ $config->{make_all_prereq} = '$**';
+ $config->{make_pp_pfx} = '!';
+ }
+ elsif ( $self->is_bsd && $config->{make} =~ /\bmake$/ ) {
+ $config->{make_family} = 'bsd';
+ $config->{make_first_prereq} = '${>:[1]}';
+ $config->{make_all_prereq} = '$>';
+ $config->{make_pp_pfx} = '.';
+ }
+ last if defined $config->{make_family};
+ }
+ unless ( defined $config->{make_family} ) {
+ $self->sorry(
+ "Cannot determine the brand of your $config->{make} utility."
+ . "\nIt is reporting itself as:\n"
+ . $buf );
+ }
+
+ if ( $self->isa_unix ) {
+ $config->{mkpath} = 'mkdir -p --';
+ $config->{chmod} = 'chmod --';
+ $config->{cp} = 'cp --';
+
+ # Symlinking should override destination.
+ $config->{ln_s} = $self->is_aix
+ ? '$(PERL5) '
+ . $self->shell_quote_filename(
+ File::Spec->catfile(
+ $self->cfg('base_dir'),
+ 'tools', 'build', 'ln_s.pl'))
+ : 'ln -nfs --';
+ $config->{rm_f} = 'rm -f --';
+ $config->{rm_rf} = 'rm -rf --';
+ $config->{rm_l} = 'rm -f --';
+ $config->{test_f} = 'test -f --';
+ }
+ else {
+ $config->{mkpath} = '$(PERL5) -MExtUtils::Command -e mkpath';
+ $config->{chmod} = '$(PERL5) -MExtUtils::Command -e chmod';
+ $config->{cp} = '$(PERL5) -MExtUtils::Command -e cp';
+ $config->{ln_s} = '$(PERL5) -MExtUtils::Command -e cp';
+ $config->{rm_f} = '$(PERL5) -MExtUtils::Command -e rm_f';
+ $config->{rm_rf} = '$(PERL5) -MExtUtils::Command -e rm_rf';
+ $config->{rm_l} =
+ '$(PERL5) -I'
+ . $self->nfp( $self->cfg('base_dir') . '/3rdparty/nqp-configure/lib' )
+ . ' -MNQP::Config -e rm_l';
+ $config->{test_f} = '$(PERL5) -MExtUtils::Command -e test_f';
+ $config->{test_f} = '$(PERL5) -MExtUtils::Command -e test_f';
+ }
+}
+
+sub abstract {
+ my @c = caller(1);
+ die "Method $c[3] must be implemented by the language class";
+}
+
+sub configure_backends {
+ abstract;
+}
+
+sub configure_misc {
+ my $self = shift;
+ my $config = $self->{config};
+ my $make_pp_pfx = $self->cfg('make_pp_pfx');
+ if ( $self->cfg('silent_build') eq 'on' ) {
+ $config->{NOECHO_declaration} = <<NOECHO_DECL;
+NOECHO = @
+${make_pp_pfx}ifdef VERBOSE_BUILD
+NOECHO =
+${make_pp_pfx}endif
+NOECHO_DECL
+ }
+ else {
+ $config->{NOECHO_declaration} = <<NOECHO_DECL;
+NOECHO =
+${make_pp_pfx}ifdef SILENT_BUILD
+NOECHO = @
+${make_pp_pfx}endif
+NOECHO_DECL
+ }
+}
+
+sub configure_refine_vars {
+ my $self = shift;
+ my $config = $self->{config};
+
+ $self->{config}{runner_suffix} = $self->{config}{bat};
+
+ unless ( $config->{prefix} ) {
+
+ # XXX This is only Unix-friendly way.
+ my $default =
+ defined( $self->option('sysroot') )
+ ? ( $self->option('sysroot') || '/usr' )
+ : File::Spec->catdir( $config->{base_dir}, 'install' );
+ $self->note( "ATTENTION",
+ "No --prefix supplied, building and installing to $default\n" );
+ $config->{prefix} = $default;
+ }
+ $config->{prefix} = File::Spec->rel2abs( $config->{prefix} );
+}
+
+sub parse_backends {
+ my $self = shift;
+ my $passed_backends = shift;
+ return uc($passed_backends) eq 'ALL'
+ ? $self->known_backends
+ : map { lc } split /,\s*/, $passed_backends;
+}
+
+sub backend_error {
+ my $self = shift;
+ my $backend = shift;
+ $self->{backend_errors}{$backend} //= [];
+ if (@_) {
+ push @{ $self->{backend_errors}{$backend} }, @_;
+ }
+ return !!@{ $self->{backend_errors}{$backend} };
+}
+
+sub backend_errors {
+ my $errs = $_[0]->{backend_errors}{ $_[1] };
+ return wantarray ? @$errs : $errs;
+}
+
+sub configure_active_backends {
+ my $self = shift;
+
+ # Most likely this would never fire. But better stay on the safe side of the
+ # Moon.
+ $self->sorry("No active backends found. Please, use --backends option.")
+ unless $self->active_backends;
+
+ for my $b ( $self->active_backends ) {
+ $self->{backend_errors}{$b} = [];
+ my $method = "configure_${b}_backend";
+ $self->$method();
+ }
+
+ $self->post_active_backends;
+}
+
+sub configure_from_options {
+ my $self = shift;
+ my $config = $self->{config};
+ for my $opt (
+ qw<prefix rakudo-home nqp-home sdkroot sysroot github-user git-protocol
+ rakudo-repo nqp-repo moar-repo roast-repo makefile-timing
+ relocatable git-cache-dir>
+ )
+ {
+ ( my $ckey = $opt ) =~ s/-/_/g;
+ $self->set_key( $ckey, $self->{options}{$opt}, default => '', );
+ }
+
+ for my $opt ( keys %{ $self->{options} } ) {
+ my $opt_val = $self->{options}{$opt} // '';
+ next if ref($opt_val);
+ ( my $cf_var = $opt ) =~ s/-/_/g;
+ $config->{"opt_$cf_var"} = $opt_val;
+ }
+
+ if ( $self->{options}{'git-reference'} ) {
+ print "===WARNING!===\n";
+ print "The --git-reference option does not exist anymore.\n";
+ print "Consider using --git-cache-dir instead.\n";
+ }
+
+ $config->{stagestats} = '--stagestats'
+ if $self->{options}{'makefile-timing'};
+
+ $config->{silent_build} = $self->option('silent-build') ? "on" : "off";
+
+ my ( $template, $out );
+ if ( $self->option('expand') ) {
+ $self->mute;
+ $template = $self->option('expand');
+ $out = $self->option('out');
+ $self->{expand_as_is} = 1;
+ }
+ else {
+ $template = 'Makefile';
+ $out = File::Spec->catfile( $config->{base_dir}, 'Makefile' );
+ $self->{out_header} = "\n# Makefile code generated by Configure.pl:\n";
+ $self->{expand_as_is} = 0;
+ }
+ $self->{template} = $template;
+ $self->{out} = $out if $out && ( $out ne '-' );
+
+ for ( @{ $self->option('set-var') // [] } ) {
+ if (/^(\w+)=(.*)$/) {
+ $config->{$1} = $2;
+ }
+ else {
+ die "Bad set config variable string: '$_'";
+ }
+ }
+}
+
+sub expand_template {
+ my $self = shift;
+
+ my $outh;
+ eval {
+
+ if ( $self->{out} ) {
+ open $outh, '>', $self->{out}
+ or die "Cannot open '$self->{out}' for writing: $!";
+ }
+ else {
+ $outh = \*STDOUT;
+ }
+
+ print $outh $self->{out_header} if $self->{out_header};
+
+ $self->fill_template_file(
+ $self->template_file_path( $self->{template}, required => 1 ),
+ $outh, as_is => $self->{expand_as_is} );
+
+ if ( $self->{out} ) {
+ close $outh
+ or die "Error while writing to '$self->{out}': $!";
+ }
+ };
+ if ($@) {
+ close $outh if $outh;
+ unlink $self->{out};
+ die $@;
+ }
+}
+
+sub save_config_status {
+ my $self = shift;
+ my $config = $self->{config};
+
+ # Save options in config.status
+ my $status_file = $self->base_path('config.status');
+ unlink($status_file);
+ if ( open( my $CONFIG_STATUS, '>', $status_file ) ) {
+ my $ckey = $config->{lclang} . "_config_status";
+ print $CONFIG_STATUS "$^X Configure.pl $config->{$ckey} \$*\n";
+ close($CONFIG_STATUS);
+ }
+ else {
+ warn "Can't write to $status_file: $!";
+ }
+}
+
+sub make_option {
+ my $self = shift;
+ my $opt = shift;
+ my %params = @_;
+
+ my $options = $self->{options};
+
+ state $bool_opt = {
+ map { $_ => 1 }
+ qw<
+ force-rebuild relocatable no-clean ignore-errors silent-build
+ >
+ };
+
+ my $opt_str = "";
+ if ( $bool_opt->{$opt} ) {
+ $opt_str = "--" . ( $options->{$opt} ? '' : 'no-' ) . "$opt";
+ }
+ elsif ( defined $options->{$opt} ) {
+ my $opt_value =
+ ref( $options->{$opt} )
+ ? join( ",", @{ $options->{$opt} } )
+ : $options->{$opt};
+ if ( $params{no_quote} ) {
+ $opt_str = qq{--$opt=$opt_value};
+ }
+ else {
+ $opt_str = qq{--$opt=} . $self->shell_quote_filename($opt_value);
+ }
+ }
+ return $opt_str;
+}
+
+# Can be overriden by lang-specific module to modify the list.
+sub ignorable_opts {
+ my $self = shift;
+ my $opt = shift;
+ return qw<gen-moar gen-nqp force-rebuild help make-install expand out
+ prefix backends set-var silent-build clean>;
+}
+
+# Generate Configure.pl options from the data we have so far.
+sub opts_for_configure {
+ my $self = shift;
+ my @opts = @_;
+ my @subopts;
+
+ @opts = keys %{ $self->{options} } unless @opts;
+
+ my @ignorables = $self->ignorable_opts;
+ my $ignorable_re = '^(?:' . join( '|', map { "$_" } @ignorables ) . ')$';
+
+ for my $opt ( grep { !/$ignorable_re/ } @opts ) {
+ my $opt_str = $self->make_option($opt);
+ push @subopts, $opt_str if $opt_str;
+ }
+ push @subopts, "--backends=" . join( ",", $self->active_backends );
+ push @subopts,
+ "--prefix=" . $self->shell_quote_filename( $self->cfg('prefix') );
+ push @subopts, "--silent-build" if $self->option('silent-build');
+ return wantarray ? @subopts : join( " ", @subopts );
+}
+
+sub is_win {
+ state $win = $^O eq 'MSWin32';
+ return $win;
+}
+
+sub is_solaris {
+ state $solaris = $^O eq 'solaris';
+ return $solaris;
+}
+
+sub is_bsd {
+ state $bsd = $^O =~ /bsd|dragonfly/;
+ return $bsd;
+}
+
+sub is_aix {
+ state $aix = $^O =~ /aix/;
+ return $aix;
+}
+
+sub isa_unix {
+
+ # The following is a partial OS list taken from Perl::OSType module,
+ # copyright by David Golden. The up-to-date version of that module can
+ # be found at https://metacpan.org/pod/Perl::OSType
+
+ return 1 if grep $^O eq $_, qw/
+ aix bsdos beos bitrig dgux dragonfly dynixptx
+ freebsd linux haiku hpux iphoneos irix darwin
+ machten midnightbsd minix mirbsd next openbsd netbsd
+ dec_osf nto svr4 svr5 sco sco_sv unicos
+ unicosmk solaris sunos cygwin msys os2 interix
+ gnu gnukfreebsd nto qnx android
+ /;
+
+ return 0;
+}
+
+sub is_executable {
+ my ( $self, $file ) = @_;
+ die "File parameter is missing in call to is_executable" if @_ < 2;
+ return $file if -x $file;
+ for my $ext (qw<exe bat>) {
+ my $fname = $file . $self->cfg($ext);
+ return $fname if -x $fname;
+ }
+ return 0;
+}
+
+sub github_url {
+ my $self = shift;
+ my ( $protocol, $user, $repo ) = @_;
+ $protocol = lc( $protocol // 'https' );
+ if ( $protocol eq 'https' || $protocol eq 'git' ) {
+ return sprintf '%s://github.com/%s/%s.git', $protocol, $user, $repo;
+ }
+ elsif ( $protocol eq 'ssh' ) {
+ return sprintf 'git%github.com@localhost:%s/%s.git', $user, $repo;
+ }
+ else {
+ die "Unknown protocol '$protocol' (fine are: ssh, https, git)";
+ }
+}
+
+sub repo_url {
+ my $self = shift;
+ my $repo = shift;
+ my %params = @_;
+ my $action = $params{action} || 'pull';
+ my $protocol = $params{protocol};
+ my $config = $self->{config};
+
+ die "Unknown repository type '$repo'" unless $self->{repo_maps}{$repo};
+ die "Bad action type '$action'" unless $action =~ /^(push|pull)$/;
+
+ my $gproto =
+ $action eq 'push'
+ ? 'ssh'
+ : $protocol || $config->{git_protocol} || 'https';
+ my $ckey = "${repo}_${action}_url";
+ my $repo_key = $repo . "_repo";
+
+ # Return user defined repo if there is one
+ if ( $config->{$repo_key} ) {
+ return $config->{$ckey} = $config->{$repo_key};
+ }
+
+ # Return cached response.
+ return $config->{$ckey} if $config->{$ckey} && !$protocol;
+
+ my ( $guser, $grepo ) = @{ $self->{repo_maps}{$repo} };
+ $guser = $config->{github_user} if $config->{github_user};
+ my $url = $self->github_url( $gproto, $guser, $grepo );
+ $config->{$ckey} = $url unless $protocol;
+ return $url;
+}
+
+sub include_path {
+ my $self = shift;
+
+ my @incs;
+ for my $ctx ( $self->contexts ) {
+ next unless $ctx->{including_file};
+ if (@incs) {
+ push @incs, "\tincluded from $ctx->{including_file}";
+ }
+ else {
+ push @incs, " in file $ctx->{including_file}";
+ }
+ }
+ return join( "\n", @incs );
+}
+
+sub find_filepath {
+ my $self = shift;
+ my $src = shift;
+ my %params = @_;
+ my $config = $self->config;
+
+ return $src if File::Spec->file_name_is_absolute($src);
+
+ my @subdirs;
+
+ push @subdirs, $params{subdir} if $params{subdir};
+ push @subdirs, @{ $params{subdirs} } if $params{subdirs};
+ push @subdirs, "" unless $params{subdirs_only};
+
+ my $ctx_subdir = $self->cfg('ctx_subdir');
+ push @subdirs, $ctx_subdir if $ctx_subdir;
+
+ my $where = $params{where} || 'templates';
+ my $where_dir = $self->cfg( "${where}_dir", strict => 1 );
+ my @suffixes;
+ push @suffixes, $params{suffix} if $params{suffix};
+ push @suffixes, @{ $params{suffixes} } if $params{suffixes};
+
+ for my $subdir (@subdirs) {
+ my $try_dir = File::Spec->catdir( $where_dir, $subdir );
+ for my $sfx (@suffixes) {
+
+ # Don't append extension if it's already there.
+ next if $sfx && $src =~ /\Q$sfx\E$/;
+ my $tfile = File::Spec->catfile( $try_dir, $src . $sfx );
+ return $tfile if -e $tfile;
+ }
+ }
+ die "File '$src' not found in base directory $where_dir"
+ . $self->include_path
+ if $params{required};
+ return "";
+}
+
+sub template_file_path {
+ my $self = shift;
+ return $self->find_filepath(
+ shift,
+ suffixes => [ "." . $self->cfg('platform'), ".in", "" ],
+ @_
+ );
+}
+
+sub build_file_path {
+ my $self = shift;
+ return $self->find_filepath(
+ shift,
+ where => 'build',
+ suffixes => [ qw<.pl .nqp .p6>, "" ],
+ @_
+ );
+}
+
+sub fill_template_file {
+ my $self = shift;
+ my ( $infile, $outfile ) = @_;
+ my %params = @_;
+
+ my $OUT;
+ if ( ref $outfile ) {
+ $OUT = $outfile;
+ }
+ else {
+ $self->msg("\nCreating $outfile ...\n");
+ open( $OUT, '>', $outfile )
+ or die "Unable to write $outfile\n";
+ }
+
+ my @infiles = ref($infile) ? @$infile : $infile;
+ for my $if (@infiles) {
+ my $ifpath = $self->template_file_path( $if, required => 1, );
+ my $s = $self->push_ctx(
+ {
+ template_file => $ifpath,
+ configs => [
+ {
+ template_file => $ifpath,
+ }
+ ],
+ }
+ );
+ my $text = slurp($ifpath);
+ print $OUT "\n# Generated from $ifpath\n" unless $params{as_is};
+ $text = $self->fill_template_text( $text, source => $ifpath );
+ print $OUT $text;
+ print $OUT "\n\n# (end of section generated from $ifpath)\n\n"
+ unless $params{as_is};
+ }
+}
+
+sub fixup_makefile {
+ my $self = shift;
+ my $text = shift;
+
+ #if ( $self->is_win ) {
+ # $text =~ s{/}{\\}g;
+ # $text =~ s{\\\*}{\\\\*}g;
+ # $text =~ s{(?:git|http):\S+}{ do {my $t = $&; $t =~ s'\\'/'g; $t} }eg;
+ # $text =~ s/.*curl.*/do {my $t = $&; $t =~ s'%'%%'g; $t}/meg;
+ #}
+
+ # TODO Timing is better be implemented as a macro
+ if ( $self->cfg('makefile_timing') ) {
+ $text =~ s{ (?<!\\\n) # not after line ending in '\'
+ ^ # beginning of line
+ (\t(?>@?[ \t]*)) # capture tab, optional @, and hspace
+ (?!-) # not before - (ignore error) lines
+ (?!cd) # not before cd lines
+ (?!echo) # not before echo lines
+ (?=\S) # must be before non-blank
+ }
+ {$1time\ }mgx;
+ }
+ return $text;
+}
+
+sub fill_template_text {
+ my $self = shift;
+ my $text = shift;
+ my %params = @_;
+ my $config = $self->config;
+
+ my $on_fail = sub {
+ my $err = shift;
+ my $msg = ref($err)
+ && $err->isa('NQP::Macros::_Err') ? $err->message : $err;
+ my $src = $params{source} ? " in template $params{source}" : "";
+ $self->sorry("$msg$src");
+ };
+
+ my $text_out =
+ NQP::Macros->new( config => $self, on_fail => $on_fail )->expand($text);
+
+ # XXX This is better be handled with makefile macros. Then the whole method
+ # would be easily replaced with Macros->expand()
+ if ( $text_out =~ /nqp::makefile/ ) {
+ $text_out = $self->fixup_makefile($text_out);
+ }
+ $text_out;
+}
+
+sub reference_dir {
+ my ($self, $name) = @_;
+ my $git_cache_dir = $self->cfg('git_cache_dir');
+ return File::Spec->catdir( $git_cache_dir, $name );
+}
+
+sub git_checkout {
+ my ( $self, $repo, $dir, $checkout ) = @_;
+
+ die "Unknown repository '$repo' in call to git_checkout"
+ unless $self->{repo_maps}{$repo};
+
+ my $config = $self->config;
+ my $options = $self->{options};
+ my $pwd = cwd();
+ my $pullurl = $self->repo_url( $repo, action => 'pull' );
+ my $pushurl = $self->repo_url( $repo, action => 'push' );
+
+ # Clone / fetch git reference repo
+ if ( $config->{git_cache_dir} ) {
+ my $ref_dir =
+ $self->reference_dir( $self->{repo_maps}{$repo}[1] );
+ if ( !-d $ref_dir ) {
+ my @ref_args = ( 'git', 'clone', '--bare' );
+ push @ref_args, "--depth=$options->{'git-depth'}"
+ if $options->{'git-depth'};
+ push @ref_args, $pullurl, $ref_dir;
+ $self->msg("Cloning reference from $pullurl\n");
+ system_or_die(@ref_args);
+ }
+ else {
+ chdir($ref_dir);
+ system_or_die( 'git', 'fetch' );
+ chdir($pwd);
+ }
+ }
+ # get an up-to-date repository
+ if ( !-d $dir ) {
+ my @args = ( 'git', 'clone' );
+ if ( $config->{git_cache_dir} ) {
+ my $ref_dir =
+ $self->reference_dir( $self->{repo_maps}{$repo}[1] );
+ die "Can't find $repo reference directory in $config->{git_cache_dir}"
+ unless $ref_dir;
+ push @args, "--reference=$ref_dir";
+ }
+ push @args, "--depth=$options->{'git-depth'}"
+ if $options->{'git-depth'};
+ push @args, $pullurl, $dir;
+ $self->msg("Cloning from $pullurl\n");
+ system_or_die(@args);
+ chdir($dir);
+
+ system( 'git', 'config', 'remote.origin.pushurl', $pushurl )
+ if defined $pushurl && $pushurl ne $pullurl;
+ }
+ else {
+ chdir($dir);
+ system_or_die( 'git', 'fetch' );
+
+ # pre-git 1.9/2.0 `--tags` did not fetch tags in addition to normal
+ # fetch https://stackoverflow.com/a/20608181/2410502 so do it separately
+ system_or_die( 'git', 'fetch', '--tags' );
+ }
+
+ if ($checkout) {
+ system_or_die( 'git', 'checkout', $checkout );
+ system_or_die( 'git', 'pull' )
+ if slurp('.git/HEAD') =~ /^ref:/;
+ }
+
+ my $git_describe;
+ if ( open( my $GIT, '-|', "git describe --tags" ) ) {
+ $git_describe = <$GIT>;
+ close($GIT);
+ chomp $git_describe;
+ }
+ chdir($pwd);
+ $git_describe;
+}
+
+sub _restore_ctx {
+ my %params = @_;
+ my $obj = $params{obj};
+
+ my $idx = 0;
+
+ for my $ctx ( @{ $obj->{contexts} } ) {
+ if ( $ctx == $params{ctx} ) {
+ splice( @{ $obj->{contexts} }, $idx, 1 );
+ return;
+ }
+ ++$idx;
+ }
+}
+
+sub contexts {
+ my @c = reverse @{ $_[0]->{contexts} };
+}
+
+sub cur_ctx {
+ return {} unless @{ $_[0]->{contexts} };
+ $_[0]->{contexts}[-1];
+}
+
+sub push_ctx {
+ my $self = shift;
+ my $ctx = shift;
+
+ die "Context must be a hash" unless ref($ctx) eq 'HASH';
+
+ warn "Context has 'config' key. Didn't you mean 'configs'?"
+ if exists $ctx->{config};
+
+ my @c = caller(1);
+
+ $ctx->{".ctx"} = {
+ from => {
+ file => $c[1],
+ line => $c[2],
+ sub => $c[3],
+ },
+ };
+
+ if ( $ctx->{configs} ) {
+ if ( ref( $ctx->{configs} ) ) {
+ my $is_valid = 1;
+ if ( ref( $ctx->{configs} ) eq 'ARRAY' ) {
+ for my $cfg ( @{ $ctx->{configs} } ) {
+ if ( ref($cfg) ne 'HASH' ) {
+ $is_valid = 0;
+ last;
+ }
+ }
+ }
+ else {
+ $is_valid = 0;
+ }
+ die "'configs' key of context must be a list of hashes"
+ unless $is_valid;
+ }
+ else {
+ $ctx->{configs} = [ $ctx->{configs} ];
+ }
+ }
+ else {
+ $ctx->{configs} = [];
+ }
+
+ push @{ $self->{contexts} }, $ctx;
+
+ return NQP::Config::_Scoping->new(
+ \&_restore_ctx,
+ obj => $self,
+ ctx => $ctx
+ );
+}
+
+sub pop_ctx {
+ my $self = shift;
+ return pop @{ $self->{contexts} };
+}
+
+# Quick push of a single config hash to the context stack.
+sub push_config {
+ my $self = shift;
+ my $ctx_config;
+
+ if ( @_ == 1 ) {
+ $ctx_config = shift;
+ }
+ else {
+ my %c = @_;
+ $ctx_config = \%c;
+ }
+
+ die "push_config is expecting a hash variable => value pairs, not a "
+ . ( ref($ctx_config) || 'scalar' )
+ unless ref($ctx_config) eq 'HASH';
+
+ return $self->push_ctx( { configs => [$ctx_config], } );
+}
+
+sub set_key {
+ my $self = shift;
+ my ( $key, $val, %params ) = @_;
+ $val //= $params{default};
+ return $self->{config}{$key} = $val;
+}
+
+sub config {
+ my $self = shift;
+ my %params = @_;
+
+ return $self->{config} if $params{no_ctx};
+
+ my %config = %{ $self->{config} };
+
+ for my $ctx ( @{ $self->{contexts} } ) {
+
+ # Reversing because the first must override the last.
+ for my $ctx_cfg ( reverse @{ $ctx->{configs} } ) {
+ @config{ keys %$ctx_cfg } = values %$ctx_cfg;
+ }
+ }
+
+ return \%config;
+}
+
+# Searches for a config variable in contexts (from latest pushed upwards) and
+# then in the main config. If context contains more than one config hash in
+# configs key then they're searched forward, from the first to the last.
+sub cfg {
+ my $self = shift;
+ my $var = shift;
+ my %params = @_;
+
+ # Don't use config method for better performance.
+ for my $ctx ( $self->contexts ) {
+ my $configs = $ctx->{configs};
+ for my $config (@$configs) {
+ if ( exists $config->{$var} ) {
+ if ( $params{with_ctx} && wantarray ) {
+ return ( $config->{$var}, $ctx );
+ }
+ return $config->{$var};
+ }
+ }
+ }
+
+ die "Can't find configuration variable '$var'"
+ if $params{strict} && !exists $self->{config}{$var};
+
+ return $self->{config}{$var};
+}
+
+# Set a configuration variable. Note that by default the variable is set on the
+# root config hash.
+sub set {
+ my $self = shift;
+ my $key = shift;
+ my $val = shift;
+ my %params = @_;
+
+ if ( my $prop = $params{in_ctx} ) {
+ my $ctx;
+ if ( $prop eq -1 ) {
+ $ctx = $self->{contexts}[-1];
+ }
+ else {
+ unless ( $ctx = $self->in_ctx($prop) ) {
+ $self->sorry( "No context '$prop' found"
+ . " while attemtped to set variable $key" );
+ }
+ }
+ $ctx->{configs}[-1]{$key} = $val;
+ }
+ else {
+ $self->{config}{$key} = $val;
+ }
+
+ return $self;
+}
+
+# Same as cfg but looking for a property, i.e. a key on a context or config
+# object itself.
+sub prop {
+ my $self = shift;
+ my $name = shift;
+ my %params = @_;
+
+ for my $ctx ( $self->contexts ) {
+ return $ctx->{$name} if exists $ctx->{$name};
+ }
+
+ die "Can't find property '$name'"
+ if $params{strict} && !exists $self->{$name};
+
+ return $self->{$name};
+}
+
+# $config->in_ctx(prop_name => "prop value")
+sub in_ctx {
+ my $self = shift;
+ my ( $prop, $val ) = @_;
+
+ for my $ctx ( $self->contexts ) {
+ return $ctx
+ if exists $ctx->{$prop}
+ && ( !defined($val) || ( $ctx->{$prop} eq $val ) );
+ }
+
+ return 0;
+}
+
+sub shell_quote_filename {
+ my $self = shift;
+ my $filename = shift;
+
+ my $platform = $self->cfg('platform');
+
+ my $qchar = $self->cfg('quote');
+ my $out = $filename;
+
+ if ( $platform eq 'windows' ) {
+ $filename =~ s{(%)}{$1$1}g;
+ $filename =~ s{(")}{\\$1}g;
+ }
+ elsif ( $platform eq 'unix' ) {
+ $filename =~ s{'}{'\\''}g;
+ }
+
+ $out = "$qchar$filename$qchar";
+
+ return $out;
+}
+
+sub nfp {
+ my $self = shift;
+ my ( $vol, $dirs, $file ) = File::Spec->splitpath(shift);
+ my %params = @_;
+ my $filename = File::Spec->canonpath(
+ File::Spec->catpath(
+ $vol,
+ File::Spec->catdir( File::Spec::Unix->splitdir($dirs) ), $file
+ )
+ );
+ $filename = $self->shell_quote_filename($filename) if $params{quote};
+ return $filename;
+}
+
+sub c_escape_string {
+ my $self = shift;
+ my $str = shift;
+ $str =~ s{\\}{\\\\}sg;
+ $str =~ s{"}{\\"}sg;
+ return $str;
+}
+
+sub sq_escape_string {
+ my $self = shift;
+ my $str = shift;
+ $str =~ s{\\}{\\\\}sg;
+ $str =~ s{'}{\\'}sg;
+ return $str;
+}
+
+#########################################################
+### Non-method subs
+#########################################################
+
+sub slash {
+ state $slash = File::Spec->catfile( '', '' );
+ return $slash;
+}
+
+sub slurp {
+ my $filename = shift;
+ open my $fh, '<', $filename
+ or die "Unable to read file '$filename'\n";
+ local $/ = undef;
+ my $text = <$fh>;
+ close $fh or die $!;
+ return $text;
+}
+
+sub os2platform {
+ my $os = shift // $^O;
+
+ # Make unix always be the last tried
+ my @platforms =
+ ( ( grep { $_ ne 'unix' } keys %os_platforms ), 'unix' );
+
+ my $platform;
+ for my $p (@platforms) {
+ my $p_or = "(?:" . join( "|", @{ $os_platforms{$p} } ) . ")";
+ if ( $os =~ /^$p_or$/ ) {
+ $platform = $p;
+ last;
+ }
+ }
+
+ $platform;
+}
+
+# Command line support, similar to ExtUtils::Command
+sub rm_l {
+ ExtUtils::Command::expand_wildcards();
+ for my $link (@ARGV) {
+ my $rc;
+ if ( $^O eq 'MSWin32' ) {
+ $rc = rmdir $link;
+ }
+ else {
+ unlink $link;
+ }
+ die "Can't delete directory $_: $!" unless $rc;
+ }
+}
+
+sub system_or_die {
+ my @cmd = @_;
+ system(@cmd) == 0
+ or die "Command failed (status $?): @cmd\n";
+}
+
+# qx{} replacement and process timing out protection.
+sub run_or_die {
+ my ( $cmd, %params ) = @_;
+ my $buf;
+ my $ok = 1;
+ my $reason;
+ my $cmdstr = ref($cmd) eq 'ARRAY' ? join( " ", @$cmd ) : $cmd;
+ if ($params{output_timeout} && IPC::Cmd->can_use_run_forked) {
+ my $last_out_at = time;
+ my $output_timeout = delete $params{output_timeout};
+ my $verbose = delete $params{verbose};
+ my $heartbeat = delete $params{heartbeat};
+ my $description = delete($params{description}) // '... Command `' . $cmdstr . '`';
+ my $on_stdout = sub {
+ print join("", @_) if $verbose;
+ $last_out_at = time;
+ };
+ my $on_stderr = sub {
+ print STDERR join("", @_) if $verbose;
+ $last_out_at = time;
+ };
+ my $started = time;
+ my $last_heartbeat = time;
+ my $resp = run_forked $cmd,
+ {
+ stdout_handler => $on_stdout,
+ stderr_handler => $on_stderr,
+ wait_loop_callback => sub {
+ my $now = time;
+ if (($now - $last_out_at) >= $output_timeout) {
+ $reason = "no output from `" . $cmdstr . "` in " . $output_timeout . "sec.";
+ $ok = 0;
+ kill 'HUP', $$;
+ }
+ if (!$verbose && $heartbeat && ($now - $last_heartbeat) >= $heartbeat) {
+ $last_heartbeat = $now;
+ say $description, ", ", ($now - $started), "sec.";
+ }
+ },
+ terminate_on_signal => 'HUP',
+ terminate_on_parent_sudden_death => 1,
+ %params
+ };
+ $ok &&= !($resp->{killed_by_signal} || $resp->{exit_code});
+ $buf = $resp->{merged};
+ }
+ else {
+ ($ok, $reason) = run( command => $cmd, %params, buffer => \$buf );
+ }
+ unless ($ok) {
+ die "Command failed: " . ($reason || "No reason provided") . "\n";
+ }
+ return $buf;
+}
+
+sub parse_revision {
+ my $rev = shift;
+ my $sep = qr/[_.]/;
+ my $rev_regex = qr/
+ (?<year> \d+)
+ $sep
+ (?<month> \d+)
+ (?:
+ $sep
+ (?<day> \d+)
+ )?
+ (?:
+ -
+ (?:
+ (?<revno> \d+) - g[a-f0-9]*
+
+ |
+
+ RC (?<rcno> \d+)
+ )
+ )?
+ $
+ /x;
+ if ( $rev =~ $rev_regex ) {
+ return ( $+{year}, $+{month}, $+{day} // 0, $+{rcno} // 0,
+ $+{revno} // 0 );
+ }
+ else {
+ die "Unrecognized revision specifier '$rev'\n";
+ }
+}
+
+sub cmp_rev {
+ my ( $a, $b ) = @_;
+ my @a = parse_revision($a);
+ my @b = parse_revision($b);
+ my $cmp = 0;
+ for ( 0 .. 4 ) {
+ $cmp = $a[$_] <=> $b[$_] if ( defined $a[$_] && defined $b[$_] );
+ last if $cmp;
+ }
+ $cmp;
+}
+
+sub read_config_from_command {
+ my $command = shift;
+ my %config = ();
+ local $_;
+ no warnings;
+ if ( open my $CONFIG, '-|', $command ) {
+ while (<$CONFIG>) {
+ if (/^([^\s=]+)=(.*)/) { $config{$1} = $2 }
+ }
+ close($CONFIG);
+ }
+ return %config;
+}
+
+sub read_config {
+ my @config_src = @_;
+ my %config = ();
+ for my $file (@config_src) {
+ if ( !-f $file ) {
+ print STDERR "No pre-existing installed file found at $file\n";
+ next;
+ }
+ %config = read_config_from_command("\"$file\" --show-config");
+ last if %config;
+ }
+ return %config;
+}
+
+1;
+
+# vim: ft=perl
Index: pkgsrc/lang/nqp/files/Macros.pm
diff -u /dev/null pkgsrc/lang/nqp/files/Macros.pm:1.1
--- /dev/null Wed Mar 12 11:27:43 2025
+++ pkgsrc/lang/nqp/files/Macros.pm Wed Mar 12 11:27:43 2025
@@ -0,0 +1,1165 @@
+use v5.10.1;
+use strict;
+use warnings;
+use utf8;
+
+package NQP::Macros::_Err;
+use Scalar::Util qw<blessed>;
+use Carp qw<longmess>;
+use Data::Dumper;
+
+our @CARP_NOT = qw<NQP::Macros::_Err>;
+
+sub new {
+ my $class = shift;
+ my $msg = shift;
+ my $self = bless {
+ err => $msg,
+ callstack => longmess(""),
+ @_,
+ }, $class;
+ return $self;
+}
+
+sub throw {
+ my $self = shift;
+
+ unless ( blessed($self) ) {
+ if ( ref( $_[0] ) && UNIVERSAL::isa( $_[0], __PACKAGE__ ) ) {
+ $_[0]->throw;
+ }
+ $self = $self->new(@_);
+ }
+ else {
+ my %params = @_;
+ @{$self}{ keys %params } = values %params;
+ }
+
+ die $self;
+}
+
+sub message {
+ my $self = shift;
+ my $err = $self->{err};
+ chomp $err;
+ my @msg = $err;
+ my $level = 1;
+ my $indent = sub {
+ my $spcs = " " x $level;
+ return map { $spcs . $_ } split /\n/s, shift;
+ };
+
+ my $file = "*no file?*";
+ my @contexts =
+ reverse(
+ $self->{contexts}
+ ? @{ $self->{contexts} }
+ : ( $self->{macro_obj} ? ( $self->{macro_obj}->cfg->contexts ) : () )
+ );
+ my @in;
+ for my $ctx (@contexts) {
+ if ( $ctx->{current_macro} ) {
+ push @in,
+ "... in macro "
+ . $ctx->{current_macro} . "("
+ . $ctx->{current_param}
+ . ") at $file";
+ }
+ if ( my $newfile = $ctx->{including_file} || $ctx->{template_file} ) {
+ $file = $newfile;
+ }
+ }
+
+ for my $msg ( reverse @in ) {
+ push @msg, $indent->($msg);
+ ++$level;
+ }
+
+ push @msg, $indent->( $self->{callstack} );
+ return join( "\n", @msg );
+}
+
+package NQP::Macros;
+use Text::ParseWords;
+use File::Spec;
+use Data::Dumper;
+use Carp qw<longmess>;
+use IPC::Cmd qw<can_run run>;
+require NQP::Config;
+
+my %preexpand = map { $_ => 1 } qw<
+ include include_capture nfp nfpl nfpq nfplq q
+ insert insert_capture insert_filelist
+ expand template ctx_template script ctx_script
+ sp_escape nl_escape c_escape sq_escape fixup uc
+ lc abs2rel shquot mkquot chomp if bpv bpm bsv
+ bsm echo use_prereqs
+>;
+
+my %receipe_macro;
+
+# Hash of externally registered macros.
+my %external;
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ return $self->init(@_);
+}
+
+sub init {
+ my $self = shift;
+ my %params = @_;
+
+ $self->{config_obj} = $params{config};
+
+ for my $p (qw<on_fail>) {
+ $self->{$p} = $params{$p} if $params{$p};
+ }
+
+ return $self;
+}
+
+sub register_macro {
+ my $self = shift;
+ my ( $name, $sub, %params ) = @_;
+
+ $self->throw("Bad macro name '$name'") unless $name && $name =~ /^\w+$/;
+ $self->throw("Macro sub isn't a code ref") unless ref($sub) eq 'CODE';
+
+ $external{$name} = $sub;
+ $preexpand{$name} = !!$params{preexpand};
+ $receipe_macro{$name} = !!$params{in_receipe};
+}
+
+sub cfg { $_[0]->{config_obj} }
+
+sub fail {
+ my $self = shift;
+ my $err = shift;
+
+ if ( ref( $self->{on_fail} ) eq 'CODE' ) {
+ $self->{on_fail}->($err);
+ }
+
+ my $msg;
+ if ( ref($err) && $err->isa('NQP::Macros::_Err') ) {
+ $msg = $err->message;
+ }
+ else {
+ $msg = $err;
+ }
+
+ die $msg;
+}
+
+sub throw {
+ my $self = shift;
+ my $err = shift;
+ if ( ref($err) && $err->isa('NQP::Macros::_Err') ) {
+ $err->throw(@_);
+ }
+ NQP::Macros::_Err->throw(
+ $err,
+ macro_obj => $self,
+ contexts => [ $self->cfg->contexts ], # copy the list
+ @_
+ );
+}
+
+sub execute {
+ my $self = shift;
+ my $macro = shift;
+ my $param = shift;
+ my $orig_param = $param;
+ my %params = @_;
+ my $cfg = $self->{config_obj};
+ my $file = $cfg->prop('including_file') || $cfg->prop('template_file');
+
+ $self->throw("Macro name is missing in call to method execute()")
+ unless $macro;
+
+ my $s = $cfg->push_ctx(
+ {
+ current_macro => $macro,
+ current_param => $orig_param,
+ configs => [
+ {
+ current_macro => $macro,
+ },
+ ],
+ }
+ );
+
+ my $method;
+
+ if ( $external{$macro} ) {
+ $method = $external{$macro};
+ }
+ else {
+ $method = $self->can("_m_$macro");
+ }
+
+ $self->throw("Unknown macro $macro") unless ref($method) eq 'CODE';
+
+ if ( !$params{no_preexapnd} && $preexpand{$macro} ) {
+ $param = $self->_expand($param);
+ }
+
+ my $out;
+ eval {
+ my $msub = sub {
+ $out = $self->$method($param);
+ };
+ if ( $receipe_macro{$macro} ) {
+ $self->in_receipe_context($msub);
+ }
+ else {
+ $msub->();
+ }
+ };
+ if ($@) {
+ $self->throw( $@, callstack => longmess("") );
+ }
+ return $out;
+}
+
+sub expand {
+ my $self = shift;
+ my $out;
+ eval { $out = $self->_expand(@_) };
+ if ($@) {
+ $self->fail($@);
+ }
+ return $out;
+}
+
+sub _expand {
+ my $self = shift;
+ my $text = shift;
+
+ $self->throw("Can't expand undefined value") unless defined $text;
+ return $text if index( $text, '@' ) < 0;
+
+ my %params = @_;
+
+ my $cfg = $self->{config_obj};
+ my $config = $cfg->{config};
+
+ my $mobj = $self;
+
+ if ( $params{isolate} ) {
+ $mobj = NQP::Macros->new( config => $cfg );
+ }
+
+ my $text_out = "";
+
+ my $last_text = "";
+
+ # @mfunc()@ @!mfunc()@
+ PARSE:
+ while (
+ $text =~ /
+ (?<eol> \z )
+ | (?<macro>
+ (?<msym> (?: @@ | @))
+ (?:
+ (?<macro_var> \w [:\w\-]* )
+ | (?:
+ (?:
+ (?<mfunc_noexp> ! )
+ | (?<mfunc_if_can> \? )
+ )*
+ (?<macro_func> \w [:\w\-]* )
+ (?>
+ \(
+ (?<mparam>
+ (
+ (?2)
+ | [^\)]
+ | \) (?! \k<msym> )
+ | (?(?{ $+{msym} eq '@' }) \z (?{ $self->throw( "Can't find closing \)$+{msym} for macro '$+{macro_func}' following <<" . $last_text . ">>" ) }))
+ )*
+ )
+ \)
+ )
+ )
+ | \z
+ )
+ \k<msym>
+ )
+ | (?<esc> \\ (?<eschr> [\\@] ) )
+ | (?<plain> .*? (?= [\\@] | \z ) )
+ /sgcxp
+ )
+ {
+ $last_text = substr( $last_text . ${^MATCH}, -30 );
+ my %m = %+;
+ if ( defined $m{plain} ) {
+ $text_out .= $m{plain};
+ }
+ elsif ( defined $m{esc} ) {
+ $text_out .= $m{eschr};
+ }
+ elsif ( defined $m{macro} ) {
+ my $chunk;
+ if ( $m{macro_var} ) {
+ $chunk = $cfg->cfg( $m{macro_var} ) // '';
+ }
+ elsif ( $m{macro_func} ) {
+ my %params;
+ $params{no_preexapnd} = !!$m{mfunc_noexp};
+ eval {
+ $chunk =
+ $mobj->execute( $m{macro_func}, $m{mparam}, %params );
+ };
+ if ($@) {
+ $self->throw( $@, force => 1 )
+ if !$m{mfunc_if_can}
+ || ( ref($@)
+ && $@->isa('NQP::Macros::_Err')
+ && $@->{force} );
+ $chunk = '';
+ }
+ }
+
+ if ( defined $chunk ) {
+ $text_out .=
+ $m{msym} eq '@@'
+ ? $mobj->_m_mkquot($chunk)
+ : $chunk;
+ }
+ }
+ elsif ( defined $m{eol} ) {
+ last PARSE;
+ }
+ else {
+ $self->throw("Impossible but can't parse input");
+ }
+ }
+
+ return $text_out;
+}
+
+sub inc_comment {
+ my $self = shift;
+ my $comment = shift;
+
+ chomp $comment;
+
+ my $len = length($comment) + 4;
+ my $bar = '#' x $len;
+ return "$bar\n# $comment #\n$bar\n";
+}
+
+sub cur_file {
+ my $self = shift;
+ my $cfg = $self->{config_obj};
+ return $cfg->prop('including_file') || $cfg->prop('template_file');
+}
+
+sub is_including {
+ my $self = shift;
+ my $file = shift;
+ my $cfg = $self->{config_obj};
+
+ for my $ctx ( $cfg->contexts ) {
+ return 1
+ if $ctx->{including_file}
+ && File::Spec->rel2abs( $ctx->{including_file} ) eq
+ File::Spec->rel2abs($file);
+ }
+ return 0;
+}
+
+sub splitwords {
+ my $str = shift;
+ $str =~ s{\\}{\\\\}sg; # quote all \ chars for shellwords.
+ return shellwords($str);
+}
+
+sub include {
+ my $self = shift;
+ my $filenames = shift;
+ my @filenames = ref($filenames) ? @$filenames : splitwords($filenames);
+ my %params = @_;
+ my $text = "";
+ my $cfg = $self->{config_obj};
+
+ $params{required} //= 1;
+
+ my %tmpl_params;
+ for my $p (qw<subdir subdirs subdirs_only>) {
+ $tmpl_params{$p} = $params{$p} if $params{$p};
+ }
+
+ for my $file ( map { $self->_m_sp_unescape($_) } @filenames ) {
+ next unless $file;
+ $file = $cfg->template_file_path( $file, required => 1, %tmpl_params );
+ my $ctx = $cfg->cur_ctx;
+ $self->throw( "Circular dependency detected on including $file"
+ . $cfg->include_path )
+ if $self->is_including;
+ $ctx->{including_file} = $file;
+ $text .= $self->inc_comment("Included from $file")
+ unless $params{as_is};
+ $text .= $self->_expand( NQP::Config::slurp($file) )
+ unless $params{no_expand};
+ $text .= $self->inc_comment("End of section included from $file")
+ unless $params{as_is};
+ }
+ return $text;
+}
+
+sub insert_list {
+ my $self = shift;
+ my $file = shift;
+ my %params = @_;
+ my $cfg = $self->{config_obj};
+ my $indent = " " x ( $cfg->{config}{list_indent} || 4 );
+ my $text = $self->_expand( NQP::Config::slurp($file) );
+ my @list = grep { length } split /\n+/s, $text;
+ if ($params{cb}) {
+ @list = map { $params{cb}->($_) } @list;
+ }
+ $text = join " \\\n$indent", @list;
+ return $text;
+}
+
+sub not_in_context {
+ my $self = shift;
+ my $cfg = $self->{config_obj};
+ my ( $ctx_name, $ctx_prop ) = @_;
+ if ( $cfg->prop($ctx_prop) ) {
+ my $tip = "";
+ if ( $cfg->in_ctx( current_macro => 'include' ) ) {
+ $tip =
+ " Perhaps you should use ctx_include macro instead of include?";
+ }
+ $self->throw("Re-entering $ctx_name context is not allowed.$tip");
+ }
+}
+
+sub is_in_context {
+ my $self = shift;
+ my ( $ctx_name, $ctx_prop ) = @_;
+ my $cfg = $self->{config_obj};
+ unless ( $cfg->prop($ctx_prop) ) {
+ $self->throw("Required '$ctx_name' context not found.");
+ }
+}
+
+# Execute callback in a custom context.
+sub do_in_context {
+ my $self = shift;
+ my $cb = shift;
+ my %props = @_;
+
+ my $ctx = $props{ctx}
+ or $self->throw("do_in_context requires 'ctx' named parameter");
+ if ( ref($ctx) ) {
+ $self->throw(
+ "do_in_context requires 'ctx' named parameter to be a hash")
+ unless ref($ctx) eq 'HASH';
+ }
+ else {
+ $ctx = { $ctx => 1 };
+ }
+ my $configs = ( $props{config} && [ $props{config} ] ) || $props{configs};
+ $ctx->{configs} = $configs;
+ my $s = $self->cfg->push_ctx($ctx);
+ return $cb->();
+}
+
+# Execute a callback in receipe context
+sub in_receipe_context {
+ my $self = shift;
+ my $cb = shift;
+ my %config = (
+ prereqs => $self->cfg->cfg('make_all_prereq'),
+ @_
+ );
+ $self->do_in_context(
+ $cb,
+ ctx => '.make_receipe',
+ config => \%config
+ );
+}
+
+# Set a config variable in receipe context.
+sub set_in_receipe {
+ my $self = shift;
+ my ($var, $val) = @_;
+ $self->cfg->set($var, $val, in_ctx => '.make_receipe');
+}
+
+sub backends_iterate {
+ my $self = shift;
+ my $cfg = $self->{config_obj};
+
+ $self->not_in_context( backends => 'backend' );
+
+ my $cb = shift;
+
+ for my $be ( $cfg->active_backends ) {
+ my $babbr = $cfg->backend_abbr($be);
+ my %config = (
+ ctx_subdir => $be,
+ backend_subdir => $be,
+ backend => $be,
+ backend_abbr => $babbr,
+ backend_prefix => $babbr,
+ bp => uc($babbr) . "_",
+ bext => $cfg->backend_ext($be),
+ btarget => $cfg->backend_target($be),
+ );
+ my %iprops = %{ $cfg->{impls}{$be} };
+ delete $iprops{config};
+ my $be_ctx = {
+ %iprops,
+ backend => $be,
+ configs => [ $cfg->{impls}{$be}{config}, \%config ],
+ };
+ my $s = $cfg->push_ctx($be_ctx);
+ $cb->(@_);
+ }
+}
+
+sub find_filepath {
+ my $self = shift;
+ my $filenames = shift;
+ my %params = @_;
+ my @filenames = splitwords($filenames);
+ my $cfg = $self->{config_obj};
+ my @out;
+
+ my $where = $params{where} // 'templates';
+ delete $params{where};
+
+ for my $src (@filenames) {
+ if ( $where eq 'build' ) {
+ push @out, $cfg->build_file_path( $src, required => 1, %params );
+ }
+ else {
+ push @out, $cfg->template_file_path( $src, required => 1, %params );
+ }
+ }
+
+ return join " ", @out;
+}
+
+# include(file1 file2)
+# Include a file. Parameter is expanded first, then the result is used a the
+# file name. File content is expanded.
+# Multiple filenames are split by spaces. If file path contains a space in it it
+# must be quoted with \
+sub _m_include {
+ shift->include(shift);
+}
+
+# insert(file1 file2)
+# Similar to include() but insert files as-is, no comments added.
+sub _m_insert {
+ shift->include( shift, as_is => 1 );
+}
+
+# ctx_include(file1 file2)
+# Same as include but only looks in the current context subdir.
+sub _m_ctx_include {
+ shift->include( shift, subdirs_only => 1 );
+}
+
+# ctx_insert(file1 file2)
+# Same as insert but only looks in the current context subdir.
+sub _m_ctx_insert {
+ shift->include( shift, as_is => 1, subdirs_only => 1 );
+}
+
+# for_backends(text)
+# Iterates over active backends and expands text in the context of each backend.
+sub _m_for_backends {
+ my $self = shift;
+ my $text = shift;
+
+ my $out = "";
+
+ my $cb = sub {
+ $out .= $self->_expand($text);
+ };
+
+ $self->backends_iterate($cb);
+
+ return $out;
+}
+
+sub _m_for {
+ my $self = shift;
+ my ($var, $text) = split " ", shift, 2;
+ my $cfg = $self->{config_obj};
+
+ my $var_text = $cfg->cfg( $self->_expand($var) );
+
+ my $out = "";
+
+ foreach my $item (split " ", $var_text) {
+ # @_@
+ my $s = $cfg->push_config(
+ '_' => $item,
+ '_item_' => $item,
+ );
+ $out .= $self->_expand($text);
+ }
+
+ return $out;
+}
+
+# expand(text)
+# Simply expands the text. Could be useful when:
+# @expand(@!nfp(@build_dir@/@macro(...)@)@)@
+# In this case under windows @!nfp()@ will result in @build_dir@\@macro(...)@
+# line. @expand()@ will then finish the expansion. This is important because
+# @build_dir@ under Windows will already have backslashes in the path.
+# NOTE that the input of expand() is pre-expanded first. So, use with extreme
+# care!
+sub _m_expand {
+ my $self = shift;
+ my $text = shift;
+ my $out = $self->_expand($text);
+}
+
+# template(file1 file2)
+# Finds corresponding template file for file names in parameter. Templates are
+# been searched in templates_dir and possibly ctx_subdir if under a context.
+sub _m_template {
+ my $self = shift;
+ return $self->find_filepath( shift, where => 'template', );
+}
+
+# ctx_template(file1 file2)
+# Similar to template but looks only in the current context subdir
+sub _m_ctx_template {
+ my $self = shift;
+ return $self->find_filepath(
+ shift,
+ where => 'template',
+ subdirs_only => 1,
+ );
+}
+
+# script(file1 file2)
+# Similar to the template above but looks in tools/build directory for files
+# with extensions .pl, .nqp, .p6.
+sub _m_script {
+ my $self = shift;
+ return $self->find_filepath( shift, where => 'build', );
+}
+
+# ctx_script(file1 file2)
+# Similar to script but looks only in the current context subdir
+sub _m_ctx_script {
+ my $self = shift;
+ return $self->find_filepath( shift, where => 'build', subdirs_only => 1, );
+}
+
+# include_capture(command line)
+# Captures output of the command line and includes it.
+sub _m_include_capture {
+ my $self = shift;
+ my $text = $self->_m_insert_capture(@_);
+ return
+ "\n"
+ . $self->inc_comment("Included from `$_[0]`")
+ . $text
+ . $self->inc_comment("End of section included from `$_[0]`");
+}
+
+# insert_capture(command line)
+# Captures output of the command line and inserts it.
+sub _m_insert_capture {
+ my $self = shift;
+ my $cfg = $self->{config_obj};
+ my $cmd_line = shift;
+ my $cmd = ( splitwords($cmd_line) )[0];
+ $self->throw("No executable '$cmd' found") unless can_run($cmd);
+ my $out;
+ my ( $ok, $err ) = run( command => $cmd_line, buffer => \$out );
+ $self->throw("Failed to execute '$cmd_line': $err\nCommand output:\n$out")
+ unless $ok;
+ return $self->_expand($out);
+}
+
+# fixup(makefile rules)
+# Fixup input makefile rules. I.e. changes dir separators / for current OS and
+# install timing measure where needed.
+sub _m_fixup {
+ my $self = shift;
+ my $text = shift;
+ return $self->{config_obj}->fixup_makefile($text);
+}
+
+# insert_list(filename)
+# Inserts a list from file filename. File content is expanded first, then split
+# by newlines into single items. Empty lines are thrown away. Each items in the
+# list will be indented by @list_indent@ spaces except for the first one.
+sub _m_insert_list {
+ my $self = shift;
+ my $cfg = $self->{config_obj};
+ my $file = $cfg->template_file_path( shift, required => 1 );
+ return $self->insert_list($file);
+}
+
+# insert_filelist(filename)
+# Similar to the insert_list macro but each item is nfp-normalized
+sub _m_insert_filelist {
+ my $self = shift;
+ my $cfg = $self->{config_obj};
+ my $file = $cfg->template_file_path( shift, required => 1 );
+ return $self->insert_list(
+ $file,
+ cb => sub { $cfg->nfp(shift) });
+}
+
+# sp_escape(a string)
+# Escapes all spaces in a string with \
+# Implicitly called by @@ macros
+sub _m_sp_escape {
+ my $self = shift;
+ my $str = shift;
+ $str =~ s{([\\\h])}{\\$1}g;
+ $str;
+}
+
+# nl_escape(a string)
+# Escapes all newlines in a string with \.
+sub _m_nl_escape {
+ my $self = shift;
+ my $str = shift;
+ $str =~ s{(\n)}{\\$1}g;
+ $str;
+}
+
+# c_escape(text)
+# Escaping for c string literals.
+sub _m_c_escape {
+ my $self = shift;
+ my $str = shift;
+ $str =~ s{\\}{\\\\}sg;
+ $str =~ s{"}{\\"}sg;
+ return $str;
+}
+
+# sq_escape(text)
+# Escaping single quotes and backslashes.
+# Can e.g. be used in a Perl '' string.
+sub _m_sq_escape {
+ my $self = shift;
+ my $str = shift;
+ $str =~ s{\\}{\\\\}sg;
+ $str =~ s{'}{\\'}sg;
+ return $str;
+}
+
+# sp_unescape(a\ st\ring)
+# Simple unescaping horizontal whitespaces from backslashes.
+sub _m_sp_unescape {
+ my $self = shift;
+ my $str = shift;
+ $str =~ s/\\([\\\h])/$1/g;
+ return $str;
+}
+
+# Iterate over whitespace separated list and execute callback for non-ws elems.
+sub _iterate_ws_list {
+ my $self = shift;
+ my $cb = shift;
+ $self->throw("_iterate_filelist callback isn't a code ref")
+ unless ref($cb) eq 'CODE';
+
+ my @elems = split /((?:(?<!\\)\s)+)/s, shift;
+ my $out = "";
+ while (@elems) {
+ my ( $file, $ws ) = ( shift @elems, shift @elems );
+ if ($file) { # If text starts with spaces $file will be empty
+ $file = $self->_m_sp_unescape($file);
+ $file = $cb->($file);
+ }
+ $out .= $file . ( $ws // "" );
+ }
+ return $out;
+}
+
+# nfpl(dir1/file1 dir2/file2)
+# Normalizes a Unix-style file path for the current OS. Also quotes path if it
+# contains spaces or $ or % on *nix/Windows. Non-separating whitespaces must be
+# quoted with \
+sub _m_nfpl {
+ my $self = shift;
+ my $cfg = $self->cfg;
+ return $self->_iterate_ws_list(
+ sub {
+ $cfg->nfp( $_[0] );
+ },
+ shift
+ );
+}
+
+# nfp(dir/file)
+# Similar to nfpl but expects only one path as input and doesn't require
+# escaping of whitespaces.
+sub _m_nfp {
+ my $self = shift;
+ return $self->cfg->nfp(shift);
+}
+
+sub _m_nfplq {
+ my $self = shift;
+ my $cfg = $self->cfg;
+ return $self->_iterate_ws_list(
+ sub {
+ $cfg->nfp( $_[0], quote => 1 );
+ },
+ shift
+ );
+}
+
+sub _m_nfpq {
+ my $self = shift;
+ return $self->cfg->nfp( shift, quote => 1 );
+}
+
+# shquot(text)
+# Escaping and quoting for shell command line.
+sub _m_shquot {
+ my $self = shift;
+ return $self->cfg->shell_quote_filename(shift);
+}
+
+# mkquot(text)
+# Escaping for current make utility
+sub _m_mkquot {
+ my $self = shift;
+ my $text = shift;
+ my $family = $self->cfg->cfg('make_family');
+ my $out;
+ if ( $family =~ /^(?:gnu|bsd)$/ ) {
+ $out = $self->_m_sp_escape($text);
+ }
+ elsif ( $family eq 'nmake' ) {
+ $out = qq<"$text"> unless $text =~ /^".*"$/;
+ }
+ else {
+ $self->throw("Don't know how to escape for $family make utility");
+ }
+ return $out;
+}
+
+sub _m_q {
+ my $self = shift;
+ my $q = $self->cfg->cfg('quote');
+ return $q . shift . $q;
+}
+
+# echo(str)
+# Produces echo command for Makefile. Takes special care of Windows oddities.
+sub _m_echo {
+ my $self = shift;
+ my $text = shift;
+ return '@echo '
+ . (
+ $self->cfg->is_win
+ ? $text
+ : $self->cfg->shell_quote_filename($text)
+ );
+}
+
+# use_prereqs(str)
+# Records prerequisites to be used to buid current target in a makefile rule
+# Allows a target to depend on more prerequisites than directly used to build
+# it.
+sub _m_use_prereqs {
+ my $self = shift;
+ my $text = shift;
+ $self->cfg->set( 'prereqs', $text, in_ctx => '.make_receipe' );
+ return $text;
+}
+
+# abs2rel(file1 file2)
+# Converts absolute file path into relative to @base_dir@
+sub _m_abs2rel {
+ my $self = shift;
+ my $cfg = $self->cfg;
+ my $base_dir = $cfg->cfg('base_dir');
+ return $self->_iterate_ws_list(
+ sub {
+ $cfg->nfp(
+ File::Spec->abs2rel(
+ File::Spec->rel2abs( $_[0], $base_dir ), $base_dir
+ )
+ );
+ },
+ shift
+ );
+}
+
+# uc(str)
+# Converts string to all uppercase
+sub _m_uc {
+ uc $_[1];
+}
+
+# lc(str)
+# Converts string to all lowercase
+sub _m_lc {
+ lc $_[1];
+}
+
+# envvar(VARNAME1 VARNAME2)
+# Generates OS-specific environment variable syntax. I.e. $VARNAME1 for *ix,
+# %VARNAME1% for Win, %%VARNAME1%% for VMS.
+sub _m_envvar {
+ my $self = shift;
+
+ my $cfg = $self->cfg;
+ my $eopen = $cfg->cfg('env_open');
+ my $eclose = $cfg->cfg('env_close');
+
+ return $self->_iterate_ws_list( sub { "${eopen}$_[0]${eclose}" }, shift );
+}
+
+# setenv(VAR)
+# Generates variable assignment construct valid for the current platform.
+sub _m_setenv {
+ my $self = shift;
+ my $var = shift;
+
+ my $p = $self->cfg->cfg('platform');
+
+ my $out = "";
+ if ( $p eq 'windows' ) {
+ $out = "@ SET $var=";
+ }
+ else {
+ $out = "$var=";
+ }
+ $out;
+}
+
+# exec(cmd)
+# Generates exec call for current platform. '@ cmd' for Windows, 'exec cmd' by
+# default.
+sub _m_exec {
+ my $self = shift;
+ my $cmd = shift;
+
+ my $p = $self->cfg->cfg('platform');
+
+ my $out = "";
+ if ( $p eq 'windows' ) {
+ $out = "@ $cmd";
+ }
+ else {
+ $out = "exec $cmd";
+ }
+ $out;
+}
+
+# chomp(text)
+# See perlfunc for chomp
+sub _m_chomp {
+ my $self = shift;
+ my $text = shift;
+ chomp($text);
+ return $text;
+}
+
+# nop(text)
+# Returns the text as-is
+sub _m_nop {
+ return $_[1];
+}
+
+# @configure_opts()@
+# Returns options to be passed to Configure.pl
+sub _m_configure_opts {
+ my $self = shift;
+ return $self->cfg->opts_for_configure;
+}
+
+# perl(code)
+# Executes a Perl code snippet and returns what the snipped returned or what
+# it's left in $out variable.
+sub _m_perl {
+ my $self = shift;
+ my $code = shift;
+ my $sub = eval <<CODE;
+sub {
+ my \$macros = shift;
+ my \$cfg = \$macros->cfg;
+ my \%config = %{ \$cfg->config };
+ my \$out = "";
+ $code
+ return \$out;
+}
+CODE
+ $self->throw($@) if $@;
+ return $sub->($self);
+}
+
+# if(var[(==|!=)value] text)
+# Inserts text if config variable is defined or compares to a value.
+sub _m_if {
+ my $self = shift;
+ my $text = shift;
+
+ my $out = "";
+ if ( $text =~ /^(?<cond>\S+)(?<ws>\s)(?<text>.*)/s ) {
+ my $cond = $+{cond};
+ my $ws = $+{ws};
+
+ # Prepend back any non-space whitespace to the text. Mostly useful for
+ # preserving \t in makefiles.
+ $text = ( $ws eq ' ' ? '' : $ws ) . $+{text};
+ my $matches = 0;
+ if ( $cond =~ /^(?<var>\w(?:\w|:\w)*)(?:(?<op>[=\!]=)(?<val>.*))?$/ ) {
+ if ( $+{op} ) {
+ my $val = $+{val};
+ my $var = $+{var};
+ my $conf_val = $self->cfg->cfg($var);
+ my $op = $+{op} eq '==' ? 'eq' : 'ne';
+ $matches = defined($conf_val)
+ && eval "\$self->cfg->cfg(\$var) $op \$val";
+ }
+ else {
+ $matches = defined $self->cfg( $+{var} );
+ }
+ }
+ elsif ( $cond =~ /^!(?<var>\w(?:\w|:\w)*)$/ ) {
+ $matches = !defined $self->cfg->cfg( $+{var} );
+ }
+ else {
+ $self->throw("Malformed condition of macro 'if': '$cond'");
+ }
+ $out = $text if $matches;
+ }
+ else {
+ $self->throw("Invalid input of macro 'if': '$text'");
+ }
+ return $out;
+}
+
+# bpv(MAKE_VAR)
+# Produces prefixed makefile variable name based on MAKE_VAR -> @bp@MAKE_VAR
+sub _m_bpv {
+ my $self = shift;
+ my $var = shift;
+ $self->is_in_context( backends => 'backend' );
+ return uc( $self->cfg->cfg('backend_prefix') ) . "_" . $var;
+}
+
+# bsv(MAKE_VAR)
+# Produces suffixed makefile variable name based on MAKE_VAR -> MAKE_VAR_@uc(@backend@)@
+sub _m_bsv {
+ my $self = shift;
+ my $var = shift;
+ $self->is_in_context( backends => 'backend' );
+ return $var . "_" . uc( $self->cfg->cfg('backend') );
+}
+
+# bpm(MAKE_VAR)
+# Produces prefixed makefile macro name based on MAKE_VAR -> $(@bp@MAKE_VAR)
+sub _m_bpm {
+ my $self = shift;
+ my $var = shift;
+ $self->is_in_context( backends => 'backend' );
+ return '$(' . uc( $self->cfg->cfg('backend_abbr') ) . "_" . $var . ')';
+}
+
+# bsm(MAKE_VAR)
+# Produces suffixed makefile macro name based on MAKE_VAR -> $(MAKE_VAR_@uc(@backend@)@)
+sub _m_bsm {
+ my $self = shift;
+ my $var = shift;
+ $self->is_in_context( backends => 'backend' );
+ return '$(' . $var . "_" . uc( $self->cfg->cfg('backend') ) . ')';
+}
+
+# varinfo(var1 var2 ...)
+# Dumps information about the context where the variable is defined.
+sub _valstr { defined $_[0] ? $_[0] : '*undef*' }
+
+sub _varinfo {
+ my $self = shift;
+ my $param = shift;
+ my %params = @_;
+ my @vars = splitwords($param);
+
+ my $max_key_length = 10;
+
+ my $rep = sub {
+ my ( $key, $val ) = @_;
+ $max_key_length = length $key if length $key > $max_key_length;
+ return [ $key, _valstr($val) ] unless ref($val);
+ local $Data::Dumper::Terse = 1;
+ my @lines = split /\n/s, Dumper($val);
+ my @rc = [ $key, _valstr( shift @lines ) ];
+ push @rc, map { [ '', _valstr($_) ] } @lines;
+ return @rc;
+ };
+
+ my $out = "\n";
+ my @report;
+ for my $var (@vars) {
+ my ( $val, $ctx ) = $self->cfg->cfg( $var, with_ctx => 1 );
+ push @report, "*** Variable $var", [ VALUE => $val ];
+ if ($ctx) {
+ my $from = $ctx->{'.ctx'}{from};
+ push @report,
+ "*** Containting context created by "
+ . "$from->{sub} "
+ . "at $from->{file}:$from->{line}", "*** Context keys:";
+ for my $ckey ( sort keys %$ctx ) {
+ next if $ckey =~ /^(?:configs|\.ctx)$/;
+ push @report, $rep->( $ckey, $ctx->{$ckey} );
+ }
+
+ push @report, "*** Context configuration variables:";
+
+ for my $config ( @{ $ctx->{configs} } ) {
+ for my $ckey ( sort keys %$config ) {
+ push @report, $rep->( $ckey, $config->{$ckey} );
+ }
+ }
+ }
+ else {
+ push @report, "*** Not from a context ***";
+ }
+ push @report, "*** End of variable $var";
+ }
+
+ for my $rline (@report) {
+ my $line;
+ if ( ref($rline) ) {
+ $line = sprintf( "%-${max_key_length}s: %s", @$rline );
+ }
+ else {
+ $line = $rline;
+ }
+ $out .= "# $line\n";
+ }
+ print $out if $params{console};
+ return $out;
+}
+
+sub _m_varinfo {
+ my $self = shift;
+ return $self->_varinfo(shift);
+}
+
+sub _m_print_varinfo {
+ my $self = shift;
+ return $self->_varinfo( shift, console => 1 );
+}
+
+1;
+
+# vim: ft=perl
Home |
Main Index |
Thread Index |
Old Index