App-CPANtoRPM

 view release on metacpan or  search on metacpan

lib/App/CPANtoRPM.pm  view on Meta::CPAN

            "my \@tmp = YAML::Tiny::LoadFile('$file'); " .
            "\$OUTPUT = \$tmp[0]" ],
          [ 'module', 'YAML', [],
            "my \@tmp = YAML::LoadFile('$file'); " .
            "\$OUTPUT = \$tmp[0]" ],
          [ 'module', 'YAML::Syck', [],
            "my \@tmp = YAML::Syck::LoadFile('$file'); " .
            "\$OUTPUT = \$tmp[0]" ],
        );

   } elsif ($file =~ /\.json$/i) {

      $succ = $self->_multiple_methods
        ( [ sub { 1; } ],
          [ 'module', 'JSON::XS', ['decode_json'],
            "my \$fh; " .
            "open \$fh,'<:utf8','$file'; " .
            "my \$json_text = do { local \$/; <\$fh> }; " .
            "\$OUTPUT = decode_json(\$json_text);" ],
          [ 'module', 'JSON', ['from_json'],
            "my \$fh; " .
            "open \$fh,'<:utf8','$file'; " .
            "my \$json_text = do { local \$/; <\$fh> }; " .
            "\$OUTPUT = from_json(\$json_text);" ],
          [ 'module', 'JSON::PP', ['decode_json'],
            "my \$fh; " .
            "open \$fh,'<:utf8','$file'; " .
            "my \$json_text = do { local \$/; <\$fh> }; " .
            "\$OUTPUT = decode_json(\$json_text);" ],
          [ 'module', 'JSON::DWIW', ['from_json'],
            "my \$fh; " .
            "open \$fh,'<:utf8','$file'; " .
            "my \$json_text = do { local \$/; <\$fh> }; " .
            "\$OUTPUT = from_json(\$json_text);" ],
        );

   } else {
      $self->_log_message('ERR',"Options file must be YAML or JSON: $file");
   }

   if (! $succ) {
      $self->_log_message('ERR',"Unable to read options file: $file");
   }

   return ()  if (! exists $OUTPUT->{$$self{'package'}});

   my @opts;

   foreach my $line (@{ $OUTPUT->{$$self{'package'}} }) {
      if ($line =~ /^(.+?)(?:\s+|=)(.+?)\s*$/) {
         push(@opts,$1,$2);
      } else {
         push(@opts,$line);
      }
   }

   return @opts;
}

###############################################################################
# This either renames or copies a file.
#
sub _backup_file {
   my($self,$file1,$file2,$copy) = @_;

   if ($copy) {

      if (-d $file2) {
         my @f  = split(/\//,$file1);
         my $f  = pop(@f);
         $file2 = "$file2/$f";
      }

      if (-f $file2) {
         if (! unlink $file2) {
            $self->_log_message('ERR',
                        "Unable to remove/overwrite file: $file2: $!");
         }
      }

      my $succ = $self->_multiple_methods( [ sub { -f "$file2" } ],
                                           ['module','File::Copy',['copy'],
                                            "copy('$file1','$file2')" ],
                                           ['system','cp',
                                            "{cp} '$file1' '$file2'"],
                                         );

      if (! $succ) {
         $self->_log_message('ERR',"Unable to copy file: $file1 -> $file2");
      }

   } else {
      if (! rename $file1,$file2) {
         $self->_log_message('ERR',"Unable to back up file: $file1");
      }
   }
}

###############################################################################
###############################################################################

# This will install a newly created RPM into a yum repository.  It will include
# both the RPM and SRPM.

sub _install_yum {
   my($self) = @_;
   my $yum   = $$self{'yum'};
   $self->_log_message('HEAD',"Installing in yum repository: $package{name}");

   if (! -d $yum) {
      $self->_log_message('ERR',"Yum directory does not exist: $yum");
   }

   if (! -d "$yum/RPMS"  ||
       ! -d "$yum/SRPMS") {
      $self->_log_message('ERR',
                          "Yum directory invalid (no RPMS/SRPM subdir): $yum");
   }

   # Copy in the binary RPM

   my $dir;
   if (-d "$yum/RPMS/$package{arch_val}") {
      $dir = "$yum/RPMS/$package{arch_val}";
   } else {
      $dir = "$yum/RPMS";
   }

   $self->_backup_file($package{'rpmfile'},$dir,"copy");

   # Copy in the source RPM

   $self->_backup_file($package{'srpmfile'},"$yum/SRPMS","copy");
}

###############################################################################
###############################################################################

# This will install a newly created RPM on the current system.  This will
# allow us to create other RPMs that depend on this one.

sub _install_rpm {
   my($self) = @_;

   $self->_log_message('HEAD',"Installing RPM: $package{name}");

   my @args = qw(-U);
   if      ($$self{'install'} eq 'new') {
      @args = qw(-i);
   } elsif ($$self{'install'} eq 'force') {
      @args = qw(-U --force);
   }

lib/App/CPANtoRPM.pm  view on Meta::CPAN

   # %_topdir macro.
   #

   if ($$self{'rpmbuild'}  &&  ! $macroval) {
      $self->_add_macro($macros,'%_topdir',$$self{'rpmbuild'});
   }

   #
   # Now make sure that the RPM build tree exists, and is writable.
   #

   my $topdir;
   if ($$self{'rpmbuild'}) {
      $topdir = $$self{'rpmbuild'};
   } else {
      $topdir = `rpm --eval '%_topdir'`;
      chomp($topdir);
   }
   my $arch   = `rpm --eval '%_arch'`;
   chomp($arch);

   $package{'topdir'}  = $topdir;
   $package{'rpmarch'} = $arch;

   $self->_log_message('INFO',"RPM build dir:  $topdir");
   $self->_log_message('INFO',"RPM build arch: $arch");

   if (! -d $topdir) {
      $self->_log_message('INFO',"Creating directory: $topdir");
      $self->_make_dir($topdir);
   }
   if (! -w $topdir) {
      $self->_log_message('ERR',
                          "Unable to write to directory: $topdir",
                          'Make sure permissions are correct.');
   }

   foreach my $subdir (qw( BUILD
                           SOURCES
                           SPECS
                           SRPMS
                           RPMS
                           RPMS/noarch
                        ),
                       "RPMS/$arch") {
      if (! -d "$topdir/$subdir") {
         $self->_log_message('INFO',"Creating directory: $subdir");
         $self->_make_dir("$topdir/$subdir");
      }
   }
}

# After the program completes, if we added any macros, revert to the original
# version.

END:
{
   my $macros = "$ENV{HOME}/.rpmmacros";
   my $self   = $package{'self'};
   if      ($package{'restore'}) {
      rename "$macros.cpantorpm",$macros  ||
        $self->_log_message('WARN',"Unable to restore .rpmmacros file: $!");
   } elsif ($package{'remove'}) {
      unlink $macros  ||
        $self->_log_message('WARN',
                            "Unable to remove temporary .rpmmacros file: $!");
   }
}

############################################################################
############################################################################

# After building the package, missing META files will have been
# created, so we will now go back and repeat the process of analyzing
# them rather than trying to get that information from the Build.PL or
# Makefile.PL files.

sub _get_meta {
   my($self) = @_;

   $self->_log_message('HEAD',
                       "Reading package metadata (post-build): $package{dir}");

   my %files = $self->_get_filelist($package{"DIR"});
   $self->_categorize_files("post_build",$package{"DIR"},%files);

   # Get rid of any requirements previously deduced since they may not
   # have come from a META file.

   foreach my $type (keys %{ $package{'requires'} }) {
      delete $package{"${type}_req"};
   }
   delete $package{'requires'};

   foreach my $f (qw(meta.json mymeta.json meta.yml mymeta.yml)) {
      my $type = ($f =~ /json/ ? 'json' : 'meta');
      $self->_get_meta_meta($type,$files{$f})    if (exists $files{$f});
   }

   $package{'arch'}     = (exists $package{'files'}{'xs'} ? '%{_arch}' : 'noarch');
   my $tmp              = `rpm --eval '$package{arch}'`;
   chomp($tmp);
   $package{'arch_val'} = $tmp;

   #
   # If we passed in --name, we'll use that.  Otherwise, we'll get it from
   # the package name (which MUST match the META name).
   #

   if ($$self{'name'}) {
      $package{'name'} = $$self{'name'};
   } else {
      if ($package{'m_name'}  &&
          $package{'m_name'} ne $package{'dist'}) {
         $self->_log_message
           ('ERR',
            "The name obtained from metadata is different: $package{dir}",
            "The name of the package obtained from the archive file",
            "and the one obtained from the metadata are not the same.",
            "   Archive:  $package{dist}",
            "   Metadata: $package{m_name}",

lib/App/CPANtoRPM.pm  view on Meta::CPAN

#
# For zip files, it can use the following methods:
#    Archive::Extract
#    Archive::Zip
#    unzip
#
sub _extract_archive {
   my($self) = @_;
   my($type) = $package{'filetype'};
   my $succ;

   # The expected directory that will be extracted.
   my $dir   = ($$self{'extracted'} ? $$self{'extracted'} : $package{'dir'});

   if      ($type eq 'zip') {

      $succ = $self->_multiple_methods
        ( [ sub { -d "$TMPDIR/$dir" } ],
          ['module','Archive::Extract',[],
           qq{ chdir('$TMPDIR');
              my \$arch=Archive::Extract->new(archive=>'$TMPDIR/$package{archive}');
              \$arch->extract(); }
          ],
          ['module','Archive::Zip',[],
           qq{ chdir('$TMPDIR');
              my \$zip = Archive::Zip->new('$TMPDIR/$package{archive}');
              \$zip->extractTree(); }
          ],
          ['system','unzip',
           "cd '$TMPDIR'; {unzip} -qq $package{archive}" ]
        );

   } else {

      my $comp = ($type eq 'tar' ? 0 : 1);
      my $opt  = ($type eq 'tar'    ? ''  :
                  $type eq 'tar.gz' ? 'z' :
                  'j');

      $succ = $self->_multiple_methods
        ( [ sub { -d "$TMPDIR/$dir" } ],
          ['module','Archive::Extract',[],
           qq{ chdir('$TMPDIR');
              my \$arch=Archive::Extract->new(archive=>'$TMPDIR/$package{archive}');
              \$arch->extract(); }
          ],
          ['module','Archive::Tar',[],
           qq{ chdir('$TMPDIR');
              Archive::Tar->extract_archive('$TMPDIR/$package{archive}',$comp); }
          ],
          ['system','tar',
           "cd '$TMPDIR'; {tar} xf$opt $package{archive}" ]
        );
   }

   if (! $succ) {
      $self->_log_message('ERR',"Unable to extract archive: $package{archive}");
   }

   if ($$self{'extracted'}) {
      if (! rename("$TMPDIR/$dir","$TMPDIR/$package{dir}")) {
         $self->_log_message
           ('ERR',
            "Unable to rename extracted directory: $package{archive}");
      }
   }
}

############################################################################
############################################################################

# Initialize the run.
sub _init {
   my($self) = @_;

   #
   # Make sure that the scratch directory exists, is new, and is empty.
   #

   $self->_log_message('HEAD',"Initializing cpantorpm ($VERSION)");
   $self->_log_message('INFO',"Creating modules for: $VERS [ $ARCH ]...");

   $self->_log_message('INFO',"Checking cpantorpm dir: $TMPDIR");
   $self->_log_indent(+1);

   if (-d $TMPDIR) {

      # If it already exists, remove it so we can start fresh.

      $self->_log_message('INFO','Exists.  Removing it...');

      my $func = sub { return ! -d $TMPDIR };

      my $succ = $self->_multiple_methods( [$func],
                                           ['module', 'File::Path', ['remove_tree'],
                                            "remove_tree('$TMPDIR')" ],
                                           ['system-null','rm',
                                            "{rm} -rf '$TMPDIR'"]
                                         );

      $self->_log_message
        ('ERR',
         "Unable to clean temporary directory: $TMPDIR",
         "Make sure that File::Path is installed, or the 'rm' command",
         "is in your path.  Also, check permissions on the directory.")
          if (! $succ);

   } elsif (-e $TMPDIR) {
      $self->_log_message('ERR',
                          'File exists.  Directory cannot be created.');
   } else {
      $self->_log_message('INFO','Does not exist.');
   }

   $self->_log_message('INFO','Creating it...');

   $self->_make_dir($TMPDIR);
   $package{'TMP'} = $TMPDIR;
   $self->_log_indent(-1);
}

sub _make_dir {
   my($self,$dir) = @_;