Merge pull request #221 from hkoba/219-perl5-40

Fix GH-219 GH-220

.github/workflows/perl_linux.yml

@@ -22,6 +22,7 @@ jobs:
           - '5.34'
           - '5.36'
           - '5.38'
+          - '5.40'
           - 'latest'
           - 'threaded'
 

Lite/Factory.pm

@@ -295,7 +295,13 @@ sub n_destroyed {$_n_destroyed}
   our %sub2self;
   DESTROY {
     (my MY $self) = @_;
-    print STDERR "# DESTROY $self\n" if DEBUG_FACTORY;
+    if (DEBUG_FACTORY) {
+      if (DEBUG_REFCNT) {
+        printf STDERR "# DESTROY %s refcnt=%d\n", $self, svref_2object($self)->REFCNT;
+      } else {
+        print STDERR "# DESTROY $self\n";
+      }
+    }
     delete $self->{_my_psgi_app};
     if (my $outer = delete $self->{_outer_psgi_app}) {
       delete $sub2self{$outer};
@@ -957,7 +963,9 @@ sub build_yatt {
 		 , $path, join(", ", @unk));
   }
 
+  printf STDERR "build_yatt.before_app_ns_new: refcnt=%d\n", svref_2object($self)->REFCNT if DEBUG_REFCNT && DEBUG_FACTORY;
   my $yatt = $self->{path2yatt}{$path} = $app_ns->new(@args, %opts);
+  printf STDERR "build_yatt.after_app_ns_new: refcnt=%d\n", svref_2object($self)->REFCNT if DEBUG_REFCNT && DEBUG_FACTORY;
 
   unless ($yatt->after_new_is_called) {
     Carp::croak("after_new is not called for $path!");

Lite/Object.pm

@@ -6,7 +6,9 @@ use mro 'c3';
 
 use fields;
 
-use YATT::Lite::XHF qw(read_file_xhf);
+require YATT::Lite::XHF;
+*read_file_xhf = *YATT::Lite::XHF::read_file_xhf;
+*read_file_xhf = *YATT::Lite::XHF::read_file_xhf;
 
 require YATT::Lite::Util;
 

Lite/Util/File.pm

@@ -55,6 +55,7 @@ sub wait_if_near_deadline {
   my $now = Time::HiRes::time;
   my $diff = $deadline - $now;
   return if $diff > $threshold;
+  return if $diff <= 0;
   usleep(int($diff * 1000 * 1000));
   $diff;
 }

misc/cpan/MyBuilder.pm

@@ -37,6 +37,7 @@ sub process_yatt_dist_files {
 
   $self->pm_files(\ my %pm_files);
   $self->pod_files(\ my %pod_files);
+  $self->script_files(\ my %script_files);
 
   foreach my $desc ([pm => \%pm_files], [pod => \%pod_files]) {
     my ($ext, $map) = @$desc;
@@ -61,15 +62,24 @@ sub process_yatt_dist_files {
 	  $self->_yatt_dist_ensure_blib_copied($_, $d);
 	}}, "Lite");
 
-  # scripts/ and elisp/ also should go into blib/lib/YATT/
+  # scripts/
+  find({no_chdir => 1, wanted => sub {
+	  return $self->prune if /^\.git|^lib$/;
+	  return if -d $_;
+	  return unless -x $_ and m{/yatt[^/]*$};
+	  my $d = $script_files{$_} = "bin/". File::Basename::basename($_);
+	  $self->_yatt_dist_ensure_blib_copied($_, $d);
+	  }}, 'scripts');
+
+  # elisp/ also should go into blib/lib/YATT/
   # XXX: This may be changed to blib/lib/YATT/Lite/ or somewhere else.
   find({no_chdir => 1, wanted => sub {
 	  return $self->prune if /^\.git|^lib$/;
 	  return if -d $_;
-	  return unless m{/yatt[^/]*$|\.el$};
+	  return unless m{\.el$};
 	  my $d = $pm_files{$_} = "lib/YATT/$_";
 	  $self->_yatt_dist_ensure_blib_copied($_, $d);
-	  }}, 'scripts', 'elisp');
+	  }}, 'elisp');
 }
 
 sub _yatt_dist_ensure_blib_copied {

scripts/libdir.pl

@@ -27,14 +27,13 @@
 
 Carp::cluck("dir=@dir\n") if $ENV{DEBUG_INC};
 
-sub MY () {__PACKAGE__}
 sub untaint_any {$_[0] =~ m{(.*)} and $1}
 use base qw/File::Spec/;
 
 my (@libdir);
 
 foreach my $dir (@dir) {
-  if (grep {$_ eq 'YATT'} MY->splitdir($dir)) {
+  if (grep {$_ eq 'YATT'} File::Spec->splitdir($dir)) {
     push @libdir, dirname(dirname($dir));
   }
 

scripts/yatt

@@ -2,7 +2,8 @@
 # -*- mode: perl; coding: utf-8 -*-
 use strict;
 use warnings qw(FATAL all NONFATAL misc);
-use FindBin; BEGIN {do "$FindBin::RealBin/libdir.pl"}
+use FindBin; BEGIN {local $_ = "$FindBin::RealBin/libdir.pl"; -r $_ and do $_}
+sub MY () {__PACKAGE__}
 #----------------------------------------
 use 5.010;
 
@@ -46,7 +47,7 @@ sub usage {
 sub cmd_help {
   my MY $self = shift;
   print STDERR <<END;
-Usage: @{[basename $0]} [--option=value] <command> [<args>]
+Usage: @{[File::Basename::basename $0]} [--option=value] <command> [<args>]
 
 Available commands are:
 END
@@ -97,5 +98,11 @@ sub find_libdir {
 
 sub after_new {
   (my MY $self) = @_;
-  $self->{cf_script_path} //= $self->find_libdir . "/YATT/scripts/";
+  $self->{cf_script_path} //= do {
+    if ($FindBin::Bin =~ m{/YATT/scripts/}) {
+      $self->find_libdir . "/YATT/scripts/"
+    } else {
+      $FindBin::Bin . "/";
+    }
+  };
 }

scripts/yatt-langserver.pl

@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use strict;
 use warnings;
-use FindBin; BEGIN {do "$FindBin::RealBin/libdir.pl"}
+use FindBin; BEGIN {local $_ = "$FindBin::RealBin/libdir.pl"; -r $_ and do $_}
 
 use YATT::Lite::LanguageServer -as_base;
 

scripts/yatt.genperl

@@ -2,7 +2,8 @@
 #----------------------------------------
 use strict;
 use warnings qw(FATAL all NONFATAL misc);
-use FindBin; BEGIN {do "$FindBin::RealBin/libdir.pl"}
+use FindBin; BEGIN {local $_ = "$FindBin::RealBin/libdir.pl"; -r $_ and do $_}
+sub MY () {__PACKAGE__}
 #----------------------------------------
 
 use YATT::Lite::Entities qw/*SYS/;
@@ -36,11 +37,11 @@ local $SYS = my $dispatcher = YATT::Lite::Factory->load_factory_offline
 
 my $nerror = 0;
 foreach my $fn (@ARGV) {
-  my $dir = dirname($dispatcher->rel2abs($fn));
+  my $dir = File::Basename::dirname($dispatcher->rel2abs($fn));
   my $dirhandler = $dispatcher->get_dirhandler($dir);
   $dirhandler->fconfigure_encoding(\*STDOUT, \*STDERR);
   my $trans = $dirhandler->open_trans;
-  my $tmpl = $trans->find_file(basename($fn)) or do {
+  my $tmpl = $trans->find_file(File::Basename::basename($fn)) or do {
     warn "No such file: $fn\n";
     $nerror++;
     next;

scripts/yatt.info

@@ -3,7 +3,8 @@
 #----------------------------------------
 use strict;
 use warnings qw(FATAL all NONFATAL misc);
-use FindBin; BEGIN {do "$FindBin::RealBin/libdir.pl"}
+use FindBin; BEGIN {local $_ = "$FindBin::RealBin/libdir.pl"; -r $_ and do $_}
+sub MY () {__PACKAGE__}
 #----------------------------------------
 
 use mro 'c3'; # XXX: Not fully compatible.
@@ -49,7 +50,7 @@ sub cmd_isa {
 	if (-d $path) {
 	  ($path)
 	} else {
-	  (dirname($path), basename($path));
+	  (File::Basename::dirname($path), File::Basename::basename($path));
 	}
       };
       my $dh = $disp->get_dirhandler($dir);

scripts/yatt.lint

@@ -2,7 +2,8 @@
 #----------------------------------------
 use strict;
 use warnings qw(FATAL all NONFATAL misc);
-use FindBin; BEGIN {do "$FindBin::RealBin/libdir.pl"}
+use FindBin; BEGIN {local $_ = "$FindBin::RealBin/libdir.pl"; -r $_ and do $_}
+sub MY () {__PACKAGE__}
 #----------------------------------------
 
 use mro 'c3';
@@ -48,7 +49,7 @@ if ($opts->{cf_tap}) {
 }
 
 foreach my $fn (@ARGV) {
-  my $dir = dirname($fn);
+  my $dir = File::Basename::dirname($fn);
   my $dirhandler = $dispatcher->get_dirhandler($dispatcher->rel2abs($dir));
   $dirhandler->fconfigure_encoding(\*STDOUT, \*STDERR);
 
@@ -72,7 +73,7 @@ foreach my $fn (@ARGV) {
   $dirhandler->configure(error_handler => $error_handler);
 
   my $trans = $dirhandler->open_trans;
-  my $tmpl = $trans->find_file(basename($fn)) or do {
+  my $tmpl = $trans->find_file(File::Basename::basename($fn)) or do {
     warn "No such file: $fn\n";
     $nerror++;
     next;

scripts/yatt.render

@@ -3,7 +3,8 @@
 #----------------------------------------
 use strict;
 use warnings qw(FATAL all NONFATAL misc);
-use FindBin; BEGIN {do "$FindBin::RealBin/libdir.pl"}
+use FindBin; BEGIN {local $_ = "$FindBin::RealBin/libdir.pl"; -r $_ and do $_}
+sub MY () {__PACKAGE__}
 #----------------------------------------
 
 use CGI;
@@ -49,7 +50,7 @@ my @command;
     MY->parse_params(\@ARGV, \%params);
     my $parameters = Hash::MultiValue->new(%params);
 
-    my $dir = dirname($dispatcher->rel2abs($file));
+    my $dir = File::Basename::dirname($dispatcher->rel2abs($file));
     $dir =~ s,/*$,/,;
     my $dirhandler = $dispatcher->get_dirhandler($dir)
       or die "Can't find dirhandler for $dir";
@@ -80,7 +81,7 @@ foreach my $cmd (@command) {
      , system => $SYS, yatt => $YATT);
 
   my ($part, $sub, $this, $args)
-    = $dirhandler->prepare_part_handler($CON, basename($file));
+    = $dirhandler->prepare_part_handler($CON, File::Basename::basename($file));
 
   my $err = catch {
     $sub->($this, $CON, @$args);

t/partial.t

@@ -134,7 +134,7 @@ END
 
   eval_ok(q{
     package t3_App1; use YATT::Lite::Inc; sub MY () {__PACKAGE__}
-    use YATT::Lite::Object -as_base;
+    use YATT::Lite::Object;
     use t3_Foo;
     use t3_Bar;
     sub m1 {
@@ -152,7 +152,7 @@ END
 
   error_like(q{
     package t3_App2; use YATT::Lite::Inc; sub MY () {__PACKAGE__}
-    use YATT::Lite::Object -as_base;
+    use YATT::Lite::Object;
     use t3_Foo;
     use t3_Bar;
     sub m1 {

t/psgi.t

@@ -14,6 +14,10 @@ use YATT::t::t_preload; # To make Devel::Cover happy.
 # A.K.A $fn:r, [file rootname] and file-name-sans-extension
 sub rootname { my $fn = shift; $fn =~ s/\.\w+$//; join "", $fn, @_ }
 
+use constant DEBUG_FACTORY => $ENV{DEBUG_YATT_FACTORY};
+use constant DEBUG_REFCNT => $ENV{DEBUG_YATT_REFCNT};
+use if DEBUG_REFCNT, B => qw/svref_2object/;
+
 BEGIN {
   # Because use YATT::Lite::DBSchema::DBIC loads DBIx::Class::Schema.
   foreach my $req (qw(Plack Plack::Test Plack::Response HTTP::Request::Common)) {
@@ -53,6 +57,8 @@ sub is_or_like($$;$) {
 	     ->psgi_file_app("$rootname.d.fallback"))
 	 );
 
+  printf STDERR "# app1.after_new: refcnt=%d\n", svref_2object($site)->REFCNT if DEBUG_REFCNT && DEBUG_FACTORY;
+
   is $site->cget('no_unicode'), undef, "No no_unicode, by default";
 
   foreach my $cf (qw/header_charset output_encoding tmpl_encoding/) {
@@ -312,6 +318,8 @@ END
 	  , "$theme $p body";
     }
   }
+
+  printf STDERR "# app1.end_of_scope: refcnt=%d\n", svref_2object($site)->REFCNT if DEBUG_REFCNT && DEBUG_FACTORY;
 }
 
 {
@@ -348,9 +356,13 @@ END
 	 )
       ->to_app;
 
+  printf STDERR "# app2.after_new: refcnt=%d\n", svref_2object($app)->REFCNT if DEBUG_REFCNT && DEBUG_FACTORY;
+
   is_deeply [$backend->paths]
     , ['', qw|/beta /cgi-bin /test.lib|]
     , "backend startup is called";
+
+  printf STDERR "# app2.end_of_scope: refcnt=%d\n", svref_2object($app)->REFCNT if DEBUG_REFCNT && DEBUG_FACTORY;
 }
 
 {
@@ -359,16 +371,28 @@ END
       , [2, 2], "Site apps are destroyed correctly.";
   };
 
-  if ($] >= 5.018
-      and not grep(defined && /^-MDevel::Cover/, $ENV{HARNESS_PERL_SWITCHES})
-    ) {
-    $t->();
-  } else {
+  my $todo = do {
+    if (grep(defined && /^-MDevel::Cover/, $ENV{HARNESS_PERL_SWITCHES})) {
+      "This test doesn't work well with Devel::Cover";
+    }
+    elsif ($] < 5.018) {
+      "Perl before 5.018 has problem about this test.";
+    }
+    elsif ($] >= 5.040) {
+      "Perl before 5.040 has problem about this test.";
+    }
+    else {
+    }
+  };
+  if ($todo) {
     TODO: {
-      local $TODO = "Perl before 5.018 has problem about this test.";
+      local $TODO = $todo;
       $t->();
     }
   }
+  else {
+    $t->();
+  }
 }
 
 done_testing();