File Coverage

blib/lib/Dist/PolicyFiles.pm

Criterion	Covered	Total	%
statement	90	90	100.0
branch	19	24	79.1
condition	12	19	63.1
subroutine	21	21	100.0
pod	10	10	100.0
total	152	164	92.6

package Dist::PolicyFiles;

use 5.014;
use strict;
use warnings;

use feature ':5.10';

our $VERSION = '0.05';


use Carp;
use File::Basename;
use File::Spec::Functions;

use Software::Security::Policy::Individual;
use Text::Template;
use GitHub::Config::SSH::UserData qw(get_user_data_from_ssh_cfg);


use constant INTERNAL_CONTRIB_MD => <<'EOT';
# Contributing to This Perl Module

Thank you for your interest in contributing!

## Reporting Issues

Please open a
[CPAN request]({$cpan_rt})
or a
[GitHub Issue]({$github_i})
if you encounter a bug or have a suggestion.
Include the following if possible:

- A clear description of the issue
- A minimal code example that reproduces it
- Expected and actual behavior
- Perl version and operating system

## Submitting Code

Pull requests are welcome! To contribute code:

1. Fork the repository and create a descriptive branch name.
2. Write tests for any new feature or bug fix.
3. Ensure all tests pass using `prove -l t/` or `make test`.
4. Follow the existing code style, especially:
   - No tabs please
   - No trailing whitespace please
   - 2 spaces indentation
5. In your pull request, briefly explain your changes and their motivation.


## Creating a Distribution (Release)

This module uses MakeMaker for creating releases (`make dist`).


## Licensing

By submitting code, you agree that your contributions may be distributed under the same license as the project.

Thank you for helping improve this module!

EOT
#Don't append a semicolon to the line above!


sub new {
  my $class = shift;
  my %args = (dir => '.', prefix => q{}, @_);
  state $allowed = {map {$_ => undef} qw(dir
                                         email
                                         full_name
                                         login
                                         module
                                         prefix
                                         uncapitalize)};
  $args{uncapitalize} = !!$args{uncapitalize};
  foreach my $arg (keys(%args)) {
    croak("$arg: unsupported argument") if !exists($allowed->{$arg});
    croak("$arg: value is not a scalar") if ref($args{$arg});
  }
  delete @args{ grep { !defined $args{$_} } keys %args };
  do {croak("$_: missing mandatory argument") if !exists($args{$_})} for (qw(login module));
  my $self = bless(\%args, $class);
  if (!(exists($self->{email}) && exists($self->{full_name}))) {
    my $udata = get_user_data_from_ssh_cfg($self->{login});
    $self->{email} //= $udata->{email2} // $udata->{email}
      // die("Could not determine email address");      # Should never happen.
    $self->{full_name} //= $udata->{full_name}
      // die("Could not determine user's full name");   # Should never happen.
  }
  return $self;
}


sub dir          {$_[0]->{dir}}
sub email        {$_[0]->{email}}
sub full_name    {$_[0]->{full_name}}
sub login        {$_[0]->{login}}
sub module       {$_[0]->{module}}
sub prefix       {$_[0]->{prefix}}
sub uncapitalize {$_[0]->{uncapitalize}}



sub create_contrib_md {
  my $self = shift;
  my $contrib_md_tmpl = shift;
  croak('Unexpected argument(s)') if @_;
  croak('Missing --module: no module specified') unless exists($self->{module});
  my $contrib_md_tmpl_str = defined($contrib_md_tmpl) ?
    do { local ( *ARGV, $/ ); @ARGV = ($contrib_md_tmpl); <> } : INTERNAL_CONTRIB_MD;
  (my $mod_name = (split(/,/, $self->{module}))[0]) =~ s/::/-/g;
  my $cpan_rt  = "https://rt.cpan.org/NoAuth/ReportBug.html?Queue=$mod_name";
  my $repo = $self->{prefix} . ($self->{uncapitalize} ? lc($mod_name) : $mod_name);
  my $github_i = "https://github.com/$self->{login}/$repo/issues";
  my $tmpl_obj = Text::Template->new(SOURCE => $contrib_md_tmpl_str, TYPE => 'STRING')
    or croak("Couldn't construct template: $Text::Template::ERROR");

  my $tmpl_vars = {cpan_rt  => $cpan_rt, github_i => $github_i};
  @{$tmpl_vars}{qw(email full_name module)} = @{$self}{qw(email full_name module)};
  my $contrib = $tmpl_obj->fill_in(HASH => $tmpl_vars)
    // croak("Couldn't fill in template: $Text::Template::ERROR");
    open(my $fh, '>', catfile($self->{dir}, 'CONTRIBUTING.md'));
    print $fh ($contrib, "\n");
    close($fh);
}



sub create_security_md {
  my $self = shift;
  my %args = (maintainer => sprintf("%s <%s>", @{$self}{qw(full_name email)}),
              program    => $self->{module},
              @_);
  if (!exists($args{url})) {
    (my $m = $self->{module}) =~ s/::/-/g;
    $m = lc($m) if $self->{uncapitalize};
    $args{url} = "https://github.com/$self->{login}/$self->{prefix}${m}/blob/main/SECURITY.md";
  }
  delete @args{ grep { !defined $args{$_} || $args{$_} eq q{}} keys %args };
  open(my $fh, '>', catfile($self->{dir}, 'SECURITY.md'));
  print $fh (Software::Security::Policy::Individual->new(\%args)->fulltext);
  close($fh);
}


1; # End of Dist::PolicyFiles


__END__