@@ -288,8 +288,20 @@ sub backup_file {
288288
289289sub _patch_file {
290290 my ($self , $new , $dst , $dir , $tt_vars , $no_backup ) = @_ ;
291+ $self -> boss-> message(5, " PATCHING '$new ' '$dst ' '$dir ' $tt_vars " . ($no_backup ||' ' ) . " \n " );
291292
292- if (!-f $new ) {
293+ if ($dst =~ / \* $ / ) {
294+ warn " WE IS PATCHIN '$new '" ;
295+ }
296+ if ($new eq ' config_H.gc' and ref ($dst ) =~ / HASH/ ) {
297+ $self -> boss-> message(5, " _patch_file: using hash of values to update config_H.gc'\n " );
298+ $self -> _update_config_H_gc (" $dir /win32/config_H.gc" , $dst );
299+ }
300+ elsif ($new eq ' config.gc' and ref ($dst ) =~ / HASH/ ) {
301+ $self -> boss-> message(5, " _patch_file: using hash of values to update config.gc'\n " );
302+ $self -> _update_config_gc (" $dir /win32/config.gc" , $dst );
303+ }
304+ elsif (!-f $new ) {
293305 warn " ERROR: non-existing file '$new '" ;
294306 }
295307 elsif ($new =~ / \. tt$ / ) {
@@ -427,6 +439,8 @@ sub _install_module {
427439 my $env = {
428440 PERL_MM_USE_DEFAULT => 1, AUTOMATED_TESTING => undef , RELEASE_TESTING => undef ,
429441 PERL5_CPANPLUS_HOME => $self -> global-> {build_ENV }-> {APPDATA }, # workaround for CPANPLUS
442+ PERL_CPANM_HOME => ($self -> global-> {build_ENV }-> {APPDATA } . ' /.cpanm' ), # GH#101
443+ PKG_CONFIG_PATH => ($self -> global-> {image_dir } . ' /c/lib/pkgconf' ), # just to be sure
430444 };
431445 # resolve macros in env{}
432446 if (defined $args {env } && ref $args {env } eq ' HASH' ) {
@@ -462,7 +476,7 @@ sub _install_module {
462476 # Execute the module install script
463477 my $rv = $self -> execute_special([' perl' , $script_pl , %params ], $log , $log , $env );
464478 unless (defined $rv && $rv == 0) {
465- rename $log , catfile($self -> global-> {debug_dir }, " mod_install_FAIL_ " . $now . " _ " . $ shortname. " .log.txt" );
479+ rename $log , catfile($self -> global-> {debug_dir }, " mod_install_ ${ shortname} _FAIL_ ${now} .log.txt" );
466480 return [], $rv ;
467481 }
468482 my $data = retrieve($nstore_file ) or die " ERROR: retrieve failed" ;
@@ -515,4 +529,179 @@ sub _apply_patch {
515529 }
516530}
517531
518- 1;
532+ sub _update_config_H_gc {
533+ my ($self , $fname , $update_hash ) = @_ ;
534+
535+ die " update hash arg is not a hash ref"
536+ if not ref ($update_hash ) =~ / HASH/ ;
537+
538+ open my $fh , $fname or die " Unable to open $fname , $! " ;
539+
540+ my $output ;
541+ while (defined (my $line = <$fh >)) {
542+ $line =~ s / [\r\n ]+$// ;
543+ if ($line =~ / #define\s +(\w +)/ and exists $update_hash -> {$1 }) {
544+ my $key = $1 ;
545+ $line
546+ = !defined $update_hash -> {$key } ? " /*#define $key \t\t / **/"
547+ : $update_hash -> {$key } eq ' define' ? " #define $key \t\t /* */"
548+ : " $update_hash ->{$key }" ;
549+ }
550+ $output .= " $line \n " ;
551+ }
552+
553+ $fh -> close ;
554+
555+
556+ # long name but otherwise we interfere with patch backups
557+ rename $fname , " $fname .orig.before_hash_update" or die $! ;
558+ open my $ofh , ' >' , $fname or die " Unable to open $fname to write to, $! " ;
559+ print {$ofh } $output ;
560+ $ofh -> close ;
561+
562+ }
563+
564+ sub _update_config_gc {
565+ my ($self , $fname , $update_hash ) = @_ ;
566+
567+ die " update hash arg is not a hash ref"
568+ if not ref ($update_hash ) =~ / HASH/ ;
569+
570+ open my $fh , $fname or die " Unable to open $fname , $! " ;
571+
572+ my @lines = (<$fh >);
573+ close $fh ;
574+
575+ my %data ;
576+ my @output ;
577+ my @perl_lines ; # lines starting with PERL
578+
579+ while (defined (my $line = shift @lines )) {
580+ $line =~ s / [\r\n ]+$// ;
581+ if ($line =~ / ^#/ ) {
582+ # headers stay as they are
583+ push @output , $line ;
584+ }
585+ elsif ($line =~ / ^PERL/ ) {
586+ push @perl_lines , $line ;
587+ }
588+ else {
589+ $line =~ m / ^([\w ]+)=(.+)$ / ;
590+ $data {$1 } = $2 ;
591+ }
592+ }
593+
594+ my $default_config_hash = $self -> _get_default_config_hash;
595+ @data {keys %$default_config_hash } = values %$default_config_hash ;
596+
597+ # fix up quoting of values
598+ foreach my $val (values %$update_hash ) {
599+ next if $val =~ / ^'/ ; # assumes symmetry, i.e. opening and closing
600+ $val = " '$val '" ;
601+ }
602+
603+ @data {keys %$update_hash } = values %$update_hash ;
604+ # foreach my $key (sort keys %$update_hash) {
605+ #
606+ # $self->boss->message(3, "Setting config, $key => $update_hash->{$key}");
607+ # $data{$key} = $update_hash->{$key};
608+ # }
609+
610+ my (@ucfirst_lines , @lcfirst_lines );
611+ foreach my $key (grep {/ ^[A-Z]/ } keys %data ) {
612+ push @ucfirst_lines , " $key =$data {$key }" ;
613+ }
614+ foreach my $key (grep {/ ^[_a-z]/ } keys %data ) {
615+ push @lcfirst_lines , " $key =$data {$key }" ;
616+ }
617+ push @output , (sort @ucfirst_lines ), (sort @lcfirst_lines ), @perl_lines ;
618+
619+ # long name but otherwise we interfere with patch backups
620+ rename $fname , " $fname .orig.before_hash_update" or die $! ;
621+ open my $ofh , ' >' , $fname or die " Unable to open $fname to write to, $! " ;
622+ say {$ofh } join " \n " , @output ;
623+ $ofh -> close ;
624+
625+ }
626+
627+ sub _get_default_config_hash {
628+ my $self = shift ;
629+
630+ my $h = {
631+ archlib => ' ~INST_TOP~\lib' ,
632+ archlibexp => ' ~INST_TOP~\lib' ,
633+ bin => ' ~INST_TOP~\bin' ,
634+ binexp => ' ~INST_TOP~\bin' ,
635+ d_vendorarch => ' define' ,
636+ d_vendorbin => ' define' ,
637+ d_vendorlib => ' define' ,
638+ d_vendorscript => ' define' ,
639+ dlext => ' xs.dll' ,
640+ installarchlib => ' ~INST_TOP~\lib' ,
641+ installbin => ' ~INST_TOP~\bin' ,
642+ installhtmldir => ' ' ,
643+ installhtmlhelpdir => ' ' ,
644+ installman1dir => ' ' ,
645+ installman3dir => ' ' ,
646+ installprefix => ' ~INST_TOP~' ,
647+ installprefixexp => ' ~INST_TOP~' ,
648+ installprivlib => ' ~INST_TOP~\lib' ,
649+ installscript => ' ~INST_TOP~\bin' ,
650+ installsitearch => ' ~INST_TOP~\site\lib' ,
651+ installsitebin => ' ~INST_TOP~\site\bin' ,
652+ installsitelib => ' ~INST_TOP~\site\lib' ,
653+ installsitescript => ' ~INST_TOP~\site\bin' ,
654+ installvendorarch => ' ~INST_TOP~\vendor\lib' ,
655+ installvendorbin => ' ~INST_TOP~\bin' ,
656+ installvendorlib => ' ~INST_TOP~\vendor\lib' ,
657+ installvendorscript => ' ~INST_TOP~\bin' ,
658+ man1dir => ' ' ,
659+ man1direxp => ' ' ,
660+ man3dir => ' ' ,
661+ man3direxp => ' ' ,
662+ perlpath => ' ~INST_TOP~\bin\perl.exe' ,
663+ privlib => ' ~INST_TOP~\lib' ,
664+ privlibexp => ' ~INST_TOP~\lib' ,
665+ scriptdir => ' ~INST_TOP~\bin' ,
666+ scriptdirexp => ' ~INST_TOP~\bin' ,
667+ sitearch => ' ~INST_TOP~\site\lib' ,
668+ sitearchexp => ' ~INST_TOP~\site\lib' ,
669+ sitebin => ' ~INST_TOP~\site\bin' ,
670+ sitebinexp => ' ~INST_TOP~\site\bin' ,
671+ sitelib => ' ~INST_TOP~\site\lib' ,
672+ sitelibexp => ' ~INST_TOP~\site\lib' ,
673+ siteprefix => ' ~INST_TOP~\site' ,
674+ siteprefixexp => ' ~INST_TOP~\site' ,
675+ sitescript => ' ~INST_TOP~\site\bin' ,
676+ sitescriptexp => ' ~INST_TOP~\site\bin' ,
677+ usevendorprefix => ' define' ,
678+ usrinc => ' C:\strawberry\c\include' ,
679+ vendorarch => ' ~INST_TOP~\vendor\lib' ,
680+ vendorarchexp => ' ~INST_TOP~\vendor\lib' ,
681+ vendorbin => ' ~INST_TOP~\bin' ,
682+ vendorbinexp => ' ~INST_TOP~\bin' ,
683+ vendorlib => ' ~INST_TOP~\vendor\lib' ,
684+ vendorlibexp => ' ~INST_TOP~\vendor\lib' ,
685+ vendorprefix => ' ~INST_TOP~\vendor' ,
686+ vendorprefixexp => ' ~INST_TOP~\vendor' ,
687+ vendorscript => ' ~INST_TOP~\bin' ,
688+ vendorscriptexp => ' ~INST_TOP~\bin' ,
689+ };
690+
691+ use POSIX qw( strftime) ;
692+ my $time = strftime ' %H:%M:%S %a %B %d %Y' , gmtime ();
693+ my $bits = $self -> global-> {bits };
694+ my $app_version = $self -> global-> {app_version };
695+ $h -> {myuname } = " Win32 strawberry-perl $app_version # $time x${bits} " ;
696+
697+ # fix up quoting of values - saves a heap of editing
698+ foreach my $val (values %$h ) {
699+ next if $val =~ / ^'/ ; # assumes symmetry, i.e. opening and closing
700+ $val = " '$val '" ;
701+ }
702+
703+ return $h ;
704+ }
705+
706+ 1;
707+
0 commit comments