package Dist::Mgr; use strict; use warnings; use version; use Capture::Tiny qw(:all); use Carp qw(croak cluck); use CPAN::Uploader; use Cwd qw(getcwd); use Data::Dumper; use Digest::SHA; use Dist::Mgr::FileData qw(:all); use Dist::Mgr::Git qw(:all); use File::Copy; use File::Copy::Recursive qw(rmove_glob); use File::Path qw(make_path rmtree); use File::Find::Rule; use JSON; use Module::Starter; use PPI; use Term::ReadKey; use Tie::File; use Exporter qw(import); our @ISA = qw(Exporter); our @EXPORT_OK = qw( add_bugtracker add_repository changes changes_bump changes_date ci_badges ci_github config config_file copyright_info copyright_bump cpan_upload git_add git_commit git_clone git_pull git_push git_ignore git_release git_repo git_status_differs git_tag init make_dist make_distclean make_manifest make_test manifest_skip manifest_t move_distribution_files remove_unwanted_files version_bump version_incr version_info ); our @EXPORT_PRIVATE = qw( _dist_dir_re _validate_git ); our %EXPORT_TAGS = ( all => [@EXPORT_OK], private => _export_private(), ); our $VERSION = '1.13'; use constant { CONFIG_FILE => 'dist-mgr.json', GITHUB_CI_FILE => 'github_ci_default.yml', GITHUB_CI_PATH => '.github/workflows/', CHANGES_FILE => 'Changes', CHANGES_ORIG_SHA => '97624d56464d7254ef5577e4a0c8a098d6c6d9e6', # Module::Starter version FSTYPE_IS_DIR => 1, FSTYPE_IS_FILE => 2, DEFAULT_DIR => 'lib/', DEFAULT_POD_DIR => '.', MAKE => $^O =~ /win32/i ? 'gmake' : 'make', }; # Public sub add_bugtracker { my ($author, $repo, $makefile) = @_; if (! defined $author || ! defined $repo) { croak("Usage: add_bugtracker(\$author, \$repository_name)\n"); } $makefile //= 'Makefile.PL'; _makefile_insert_bugtracker($author, $repo, $makefile); } sub add_repository { my ($author, $repo, $makefile) = @_; if (! defined $author || ! defined $repo) { croak("Usage: add_repository(\$author, \$repository_name)\n"); } $makefile //= 'Makefile.PL'; _makefile_insert_repository($author, $repo, $makefile); } sub changes { my ($module, $file) = @_; croak("changes() needs a module parameter") if ! defined $module; $file //= 'Changes'; # Overwrite the Changes file if there aren't any dates in it my @contents; my $changes_date_count = 0; if (-e $file) { my ($contents, $tie) = _changes_tie($file); $changes_date_count = grep /\d{4}-\d{2}-\d{2}/, $contents; untie $tie; } if (! -e $file || ! $changes_date_count) { my @contents = _changes_file($module); _changes_write_file($file, \@contents); } return @contents; } sub changes_bump { my ($version, $file) = @_; croak("changes_bump() requires a version sent in") if ! defined $version; _validate_version($version); $file //= 'Changes'; my ($contents, $tie) = _changes_tie($file); for (0..$#$contents) { if ($contents->[$_] =~ /^\d+\.\d+\s+/) { $contents->[$_-1] = "\n$version UNREL\n -\n\n"; last; } } untie $tie; } sub changes_date { my ($file) = @_; $file //= 'Changes'; my ($contents, $tie) = _changes_tie($file); my ($d, $m, $y) = (localtime)[3, 4, 5]; $y += 1900; $m += 1; $m = "0$m" if length $m == 1; $d = "0$d" if length $d == 1; for (0..$#$contents) { if ($contents->[$_] =~ /^(.*)\s+UNREL/) { $contents->[$_] = "$1 $y-$m-$d"; last; } } untie $tie; } sub ci_badges { if (scalar @_ < 2) { croak("ci_badges() needs \$author and \$repo sent in"); } my ($author, $repo, $fs_entry) = @_; $fs_entry //= DEFAULT_DIR; my $exit = 0; for (_module_find_files($fs_entry)) { $exit = -1 if _module_insert_ci_badges($author, $repo, $_) == -1; } return $exit; } sub ci_github { my ($os) = @_; if (defined $os && ref $os ne 'ARRAY') { croak("\$os parameter to ci_github() must be an array ref"); } # Add the CI file to MANIFEST.SKIP if (-e 'MANIFEST.SKIP') { open my $fh, '<', 'MANIFEST.SKIP' or croak("Can't open MANIFEST.SKIP for reading"); my @makefile_skip_contents = <$fh>; if (grep !m|\.github$|, @makefile_skip_contents) { close $fh; open my $wfh, '>>', 'MANIFEST.SKIP' or croak("Can't open MANIFEST.SKIP for writing"); print $wfh '^\.github/'; } } else { open my $wfh, '>>', 'MANIFEST.SKIP' or croak("Can't open MANIFEST.SKIP for writing"); print $wfh '^\.github/'; } my @contents = _ci_github_file($os); _ci_github_write_file(\@contents); return @contents; } sub config { my ($args, $file) = @_; if (! defined $args) { croak("config() requires \$args hash reference parameter"); } elsif (ref $args ne 'HASH') { croak("\$args parameter must be a hash reference."); } $file = config_file() if ! defined $file; my $conf; if (-e $file && -f $file) { { local $/; open my $fh, '<', $file or croak "Can't open config file $file: $!"; my $json = <$fh>; $conf = decode_json $json; for (keys %{ $conf }) { delete $conf->{$_} if $conf->{$_} eq ''; } } } else { # No config file present _config_file_write($file, _config_file()); print "\nGenerated new configuration file: $file\n"; } %{ $args } = (%{ $args }, %{ $conf }) if $conf; return $args; } sub config_file { my $file = $^O =~ /win32/i ? "$ENV{USERPROFILE}/${\CONFIG_FILE}" : "$ENV{HOME}/${\CONFIG_FILE}"; return $file; } sub copyright_bump { my ($fs_entry) = @_; $fs_entry //= DEFAULT_POD_DIR; _validate_fs_entry($fs_entry); my ($year) = (localtime)[5]; $year += 1900; my @pod_files = _pod_find_files($fs_entry); my %info; for my $pod_file (@pod_files) { my ($contents, $tie) = _pod_tie($pod_file); for (0 .. $#$contents) { if ($contents->[$_] =~ /^(Copyright\s+)\d{4}(\s+.*)/) { $contents->[$_] = "$1$year$2"; $info{$pod_file} = $year; last; } } untie $tie; } return \%info; } sub copyright_info { my ($fs_entry) = @_; $fs_entry //= DEFAULT_POD_DIR; _validate_fs_entry($fs_entry); my @pod_files = _pod_find_files($fs_entry); my %copyright_info; for my $file (@pod_files) { my $copyright = _pod_extract_file_copyright($file); next if ! defined $copyright || $copyright !~ /^\d{4}$/; $copyright_info{$file} = $copyright if defined $copyright; } return \%copyright_info; } sub cpan_upload { my ($dist_file_name, %args) = @_; config(\%args); if (! defined $dist_file_name) { croak("cpan_upload() requires the name of a distribution file sent in"); } if (! -f $dist_file_name) { croak("File name sent to cpan_upload() isn't a valid file"); } $args{user} //= $args{cpan_id}; $args{password} //= $args{cpan_pw}; $args{user} = $ENV{CPAN_USERNAME} if ! $args{user}; $args{password} = $ENV{CPAN_PASSWORD} if ! $args{password}; if (! $args{user} || ! $args{password}) { croak("\ncpan_upload() requires --cpan_id and --cpan_pw"); } if ($args{dry_run}) { print "\nCPAN upload is in dry run mode... nothing will be uploaded\n"; } CPAN::Uploader->upload_file( $dist_file_name, \%args ); print "\nSuccessfully uploaded $dist_file_name to the CPAN\n"; return %args; } sub git_add { _git_add(); } sub git_ignore { my ($dir) = @_; $dir //= '.'; my @content = _git_ignore_file(); _git_ignore_write_file($dir, \@content); return @content; } sub git_commit { _git_commit(@_); } sub git_clone { _git_clone(@_); } sub git_push { _git_push(@_); } sub git_pull { _git_pull(@_); } sub git_release { _git_release(@_); } sub git_repo { _git_repo(); } sub git_status_differs { _git_status_differs(@_); } sub git_tag { _git_tag(@_); } sub init { my (%args) = @_; config(\%args); my $cwd = getcwd(); if ($cwd =~ _dist_dir_re()) { croak "Can't run init() while in the '$cwd' directory"; } $args{license} = 'artistic2' if ! exists $args{license}; $args{builder} = 'ExtUtils::MakeMaker'; for (qw(modules author email)) { if (! exists $args{$_}) { croak("init() requires '$_' in the parameter hash"); } } if (ref $args{modules} ne 'ARRAY') { croak("init()'s 'modules' parameter must be an array reference"); } if ($args{verbose}) { delete $args{verbose}; Module::Starter->create_distro(%args); } else { capture_merged { Module::Starter->create_distro(%args); }; } my ($module) = (@{ $args{modules} })[0]; my $module_file = $module; $module_file =~ s/::/\//g; $module_file = "lib/$module_file.pm"; my $module_dir = $module; $module_dir =~ s/::/-/g; chdir $module_dir or croak("Can't change into directory '$module_dir'"); unlink $module_file or croak("Can't delete the Module::Starter module '$module_file': $!"); _module_write_template($module_file, $module, $args{author}, $args{email}); chdir '..' or croak "Can't change into original directory"; } sub manifest_skip { my ($dir) = @_; $dir //= '.'; my @content = _manifest_skip_file(); _manifest_skip_write_file($dir, \@content); return @content; } sub manifest_t { my ($dir) = @_; $dir //= './t'; my @content = _manifest_t_file(); _manifest_t_write_file($dir, \@content); return @content; } sub move_distribution_files { my ($module) = @_; if (! defined $module) { croak("_move_distribution_files() requires a module name sent in"); } my $module_dir = $module; $module_dir =~ s/::/-/g; my @move_count = rmove_glob("$module_dir/*", '.') or croak("Can't move files from the '$module_dir' directory: $!"); my $dist_count = _default_distribution_file_count(); for my $outer_idx (0..$#move_count) { my $outer = $move_count[$outer_idx]; for my $inner_idx (0..$#$outer) { my $inner = $move_count[$outer_idx][$inner_idx]; for (0..$#$inner) { if ($inner->[$_] != $dist_count->[$outer_idx][$inner_idx][$_]) { croak("Results from the move are mismatched... bailing out"); } } } } rmtree $module_dir or croak("Couldn't remove the '$module_dir' directory"); return 0; } sub remove_unwanted_files { for (_unwanted_filesystem_entries()) { rmtree $_; } make_manifest(); return 0; } sub make_dist { my ($verbose) = @_; my $cmd = "${\MAKE} dist"; $verbose ? `$cmd` : capture_merged {`$cmd`}; if ($? != 0) { croak("Exit code $? returned... '${\MAKE} dist' failed"); } return $?; } sub make_distclean { my ($verbose) = @_; my $cmd = "${\MAKE} distclean"; $verbose ? print `$cmd` : capture_merged {`$cmd`}; if ($? != 0) { croak("Exit code $? returned... '${\MAKE} distclean' failed\n"); } return $?; } sub make_manifest { my ($verbose) = @_; if ($verbose) { if (-f 'MANIFEST') { unlink 'MANIFEST' or die "make_manifest() Couldn't remove MANIFEST\n"; } print `$^X Makefile.PL`; print `${\MAKE} manifest`; make_distclean($verbose); } else { capture_merged { if (-f 'MANIFEST') { unlink 'MANIFEST' or die "make_manifest() Couldn't remove MANIFEST\n"; } `$^X Makefile.PL`; `${\MAKE} manifest`; make_distclean($verbose); }; } if ($? != 0) { croak("Exit code $? returned... '${\MAKE} manifest' failed\n"); } return $?; } sub make_test { my ($verbose) = @_; if ($verbose) { print `$^X Makefile.PL`; print `${\MAKE} test`; } capture_merged { `$^X Makefile.PL`; `${\MAKE} test`; }; if ($? != 0) { croak("Exit code $? returned... '${\MAKE} test' failed\n"); } return $?; } sub version_bump { my ($version, $fs_entry) = @_; my $dry_run = 0; if (defined $version && $version =~ /^-/) { print "\nDry run\n\n"; $version =~ s/-//; $dry_run = 1; } $fs_entry //= DEFAULT_DIR; _validate_version($version); _validate_fs_entry($fs_entry); my @module_files = _module_find_files($fs_entry); my %files; for (@module_files) { my $current_version = _module_extract_file_version($_); my $version_line = _module_extract_file_version_line($_); my @file_contents = _module_fetch_file_contents($_); if (! defined $version_line) { next; } if (! defined $current_version) { next; } if (version->parse($current_version) >= version->parse($version)) { croak( "Your new version $version must be greater than the current " . "one, $current_version" ); } my $mem_file; open my $wfh, '>', \$mem_file or croak("Can't open mem file!: $!"); for my $line (@file_contents) { chomp $line; if ($line eq $version_line) { $line =~ s/$current_version/$version/; } $line .= "\n"; # Write out the line to the in-memory temp file print $wfh $line; $files{$_}{from} = $current_version; $files{$_}{to} = $version; } close $wfh; $files{$_}{dry_run} = $dry_run; $files{$_}{content} = $mem_file; if (! $dry_run) { # Write out the actual file _module_write_file($_, $mem_file); } } return \%files; } sub version_incr { my ($version) = @_; croak("version_incr() needs a version number sent in") if ! defined $version; my $incremented_version; _validate_version($version); return sprintf("%.2f", $version + '0.01'); } sub version_info { my ($fs_entry) = @_; $fs_entry //= DEFAULT_DIR; _validate_fs_entry($fs_entry); my @module_files = _module_find_files($fs_entry); my %version_info; for (@module_files) { my $version = _module_extract_file_version($_); $version_info{$_} = $version; } return \%version_info; } # Changes file related sub _changes_tie { # Ties the Changes file to an array my ($changes) = @_; croak("_changes_tie() needs a Changes file name sent in") if ! defined $changes; my $tie = tie my @changes, 'Tie::File', $changes; return (\@changes, $tie); } sub _changes_write_file { # Writes out the custom Changes file my ($file, $content) = @_; open my $fh, '>', $file or cluck("Can't open file $file: $!"); for (@$content) { print $fh "$_\n" } close $fh; return 0; } # CI related sub _ci_github_write_file { # Writes out the Github Actions config file my ($contents) = @_; if (ref $contents ne 'ARRAY') { croak("_ci_github_write_file() requires an array ref of contents"); } my $ci_file //= GITHUB_CI_PATH . GITHUB_CI_FILE; make_path(GITHUB_CI_PATH) if ! -d GITHUB_CI_PATH; open my $fh, '>', $ci_file or croak $!; print $fh "$_\n" for @$contents; } # Configuration related sub _config_file_write { my ($file, $contents) = @_; if (ref $contents ne 'HASH') { croak("_config_file_write() requires a hash ref of contents"); } my $jobj = JSON->new; my $json = $jobj->pretty->encode($contents); open my $fh, '>', $file or croak "Can't open config $file for writing: $!"; print $fh $json; } # Distribution related sub _default_distribution_file_count { # Returns the file count in a distribution # This is used to ensure everything moved OK return [ [ [1, 0, 0] ], [ [1, 0, 0] ], [ [3, 2, 0] ], [ [1, 0, 0] ], [ [1, 0, 0] ], [ [1, 0, 0] ], [ [5, 1, 0] ], [ [2, 1, 0] ], ]; } # Git related sub _git_ignore_write_file { # Writes out the .gitignore file my ($dir, $content) = @_; open my $fh, '>', "$dir/.gitignore" or croak $!; for (@$content) { print $fh "$_\n" } return 0; } # Makefile related sub _makefile_tie { # Ties the Makefile.PL file to an array my ($mf) = @_; croak("_makefile_tie() needs a Makefile name sent in") if ! defined $mf; my $tie = tie my @mf, 'Tie::File', $mf; return (\@mf, $tie); } sub _makefile_insert_meta_merge { # Inserts the META_MERGE section into Makefile.PL my ($mf) = @_; croak("_makefile_insert_meta_merge() needs a Makefile tie sent in") if ! defined $mf; # Check to ensure we're not duplicating return if grep /META_MERGE/, @$mf; for (0..$#$mf) { if ($mf->[$_] =~ /MIN_PERL_VERSION/) { splice @$mf, $_+1, 0, _makefile_section_meta_merge(); last; } } } sub _makefile_insert_bugtracker { # Inserts bugtracker information into Makefile.PL my ($author, $repo, $makefile) = @_; if (! defined $makefile) { croak("_makefile_insert_bugtracker() needs author, repo and makefile"); } my ($mf, $tie) = _makefile_tie($makefile); return -1 if grep /bugtracker/, @$mf; if (grep ! /META_MERGE/, @$mf) { _makefile_insert_meta_merge($mf); } for (0..$#$mf) { if ($mf->[$_] =~ /resources => \{/) { splice @$mf, $_+1, 0, _makefile_section_bugtracker($author, $repo); last; } } untie $tie; return 0; } sub _makefile_insert_repository { # Inserts repository information to Makefile.PL my ($author, $repo, $makefile) = @_; if (! defined $makefile) { croak("_makefile_insert_repository() needs author, repo and makefile"); } my ($mf, $tie) = _makefile_tie($makefile); return -1 if grep /repository/, @$mf; if (grep ! /META_MERGE/, @$mf) { _makefile_insert_meta_merge($mf); } for (0..$#$mf) { if ($mf->[$_] =~ /resources => \{/) { splice @$mf, $_+1, 0, _makefile_section_repo($author, $repo); last; } } untie $tie; return 0; } # MANIFEST related sub _manifest_skip_write_file { # Writes out the MANIFEST.SKIP file my ($dir, $content) = @_; open my $fh, '>', "$dir/MANIFEST.SKIP" or croak $!; for (@$content) { print $fh "$_\n" } return 0; } sub _manifest_t_write_file { # Writes out the t/manifest.t test file my ($dir, $content) = @_; open my $fh, '>', "$dir/manifest.t" or croak("Can't open t/manifest.t for writing: $!\n"); for (@$content) { print $fh "$_\n" } return 0; } # Module related sub _module_extract_file_version { # Extracts the version number from a module's $VERSION definition line my ($module_file) = @_; my $version_line = _module_extract_file_version_line($module_file); if (defined $version_line) { if ($version_line =~ /=(.*)$/) { my $ver = $1; $ver =~ s/\s+//g; $ver =~ s/;//g; $ver =~ s/[a-zA-Z]+//g; $ver =~ s/"//g; $ver =~ s/'//g; if (! defined eval { version->parse($ver); 1 }) { warn("$_: Can't find a valid version\n"); return undef; } return $ver; } } else { warn("$_: Can't find a \$VERSION definition\n"); } return undef; } sub _module_extract_file_version_line { # Extracts the $VERSION definition line from a module file my ($module_file) = @_; my $doc = PPI::Document->new($module_file); my $token = $doc->find( sub { $_[1]->isa("PPI::Statement::Variable") and $_[1]->content =~ /\$VERSION/; } ); return undef if ref $token ne 'ARRAY'; my $version_line = $token->[0]->content; return $version_line; } sub _module_fetch_file_contents { # Fetches the file contents of a module file my ($file) = @_; open my $fh, '<', $file or croak("Can't open file '$file' for reading!: $!"); my @contents = <$fh>; close $fh; return @contents; } sub _module_find_files { # Finds module files my ($fs_entry, $module) = @_; $fs_entry //= DEFAULT_DIR; if (defined $module) { $module =~ s/::/\//g; $module .= '.pm'; } else { $module = '*.pm'; } return File::Find::Rule->file() ->name($module) ->in($fs_entry); } sub _module_insert_ci_badges { # Inserts the CI and Coveralls badges into POD my ($author, $repo, $module_file) = @_; my ($mf, $tie) = _module_tie($module_file); return -1 if grep /badge\.svg/, @$mf; for (0..$#$mf) { if ($mf->[$_] =~ /^=head1 NAME/) { splice @$mf, $_+3, 0, _module_section_ci_badges($author, $repo); last; } } untie $tie; return 0; } sub _module_tie { # Ties a module file to an array my ($mod_file) = @_; croak("Acme-STEVEB() needs a module file name sent in") if ! defined $mod_file; my $tie = tie my @mf, 'Tie::File', $mod_file; return (\@mf, $tie); } sub _module_write_file { # Writes out a Perl module file my ($module_file, $content) = @_; open my $wfh, '>', $module_file or croak("Can't open '$module_file' for writing!: $!"); print $wfh $content; close $wfh or croak("Can't close the temporary memory module file!: $!"); } sub _module_write_template { # Writes out our custom module template after init() my ($module_file, $module, $author, $email) = @_; if (! defined $module_file) { croak("_module_write_template() needs the module's file name sent in"); } if (! defined $module || ! defined $author || ! defined $email) { croak("_module_template_file() requires 'module', 'author' and 'email' parameters"); } my @content = _module_template_file($module, $author, $email); open my $wfh, '>', $module_file or croak("Can't open '$module_file' for writing!: $!"); print $wfh "$_\n" for @content; } # POD related sub _pod_extract_file_copyright { # Extracts the copyright year from POD my ($module_file) = @_; my $copyright_line = _pod_extract_file_copyright_line($module_file); if (defined $copyright_line) { if ($copyright_line =~ /^Copyright\s+(\d{4})\s+\w+/) { return $1; } } else { warn("$_: Can't find a Copyright definition\n"); } return undef; } sub _pod_extract_file_copyright_line { # Extracts the Copyright line from a module file my ($pod_file) = @_; open my $fh, '<', $pod_file or croak("Can't open POD file $pod_file: $!"); while (<$fh>) { if (/^Copyright\s+\d{4}\s+\w+/) { return $_; } } } sub _pod_find_files { # Finds POD files my ($fs_entry) = @_; $fs_entry //= DEFAULT_POD_DIR; return File::Find::Rule->file() ->name('*.pod', '*.pm', '*.pl') ->in($fs_entry); } sub _pod_tie { # Ties a POD file to an array my ($pod_file) = @_; croak("_pod_tie() needs a POD file name sent in") if ! defined $pod_file; my $tie = tie my @pf, 'Tie::File', $pod_file; return (\@pf, $tie); } # Validation related sub _dist_dir_re { # Capture permutations of the distribution directory for various # CPAN testers # Use YAPE::Regex::Explain for details return qr/dist-mgr(?:-\d+\.\d+)?(?:-\w+|_\d+)?$/i; } sub _validate_git { my $sep = $^O =~ /win32/i ? ';' : ':'; return grep {-x "$_/git" } split /$sep/, $ENV{PATH}; } sub _validate_fs_entry { # Validates a file system entry as valid my ($fs_entry) = @_; cluck("Need name of dir or file!") if ! defined $fs_entry; return FSTYPE_IS_DIR if -d $fs_entry; return FSTYPE_IS_FILE if -f $fs_entry; croak("File system entry '$fs_entry' is invalid"); } sub _validate_version { # Parses a version number to ensure it is valid my ($version) = @_; croak("version parameter must be supplied!") if ! defined $version; if (! defined eval { version->parse($version); 1 }) { croak("The version number '$version' specified is invalid"); } } # Miscellaneous sub _export_private { push @EXPORT_OK, @EXPORT_PRIVATE; return \@EXPORT_OK; } sub __placeholder {} 1; __END__ =head1 AUTHOR Steve Bertrand, C<< >> =head1 LICENSE AND COPYRIGHT Copyright 2022 Steve Bertrand. This program is free software; you can redistribute it and/or modify it under the terms of the the Artistic License (2.0). You may obtain a copy of the full license at: L