backup results from the CPAN

App-CPANtoRPM

view release on metacpan or search on metacpan

          [ '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);
   }

   my @cmd = ('rpm',@args,$package{rpmfile});

   if ($<) {
      my $sudo = $self->_find_exe('sudo');
      if (! $sudo) {
         $self->_log_message('ERR',
                             'sudo not found.  The rpm will not be installed.');
      }
      unshift (@cmd,$sudo);
   }

   my $cmd = join(' ',@cmd);
   $self->_log_message('INFO',"Attempting system command: $cmd");

   if (system(@cmd) != 0) {
      $self->_log_message('ERR','Installation failed.');
   }
}

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

# This will sign a newly created RPM.  It may use the perl expect module,
# the expect executable, or it can do it interactively.

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

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

   my $gpg = $self->_find_exe('gpg');
   if (! $gpg) {
      $self->_log_message('ERR',"gpg program not found in path.");
   }

   #
   # First, let's get the value of the GPG path
   #

   my $path  = '';    # The gpg option to set the path to use (if not the default)

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

      return 1;
   }
   return 0;
}

{
   my $flag;

   sub _sign_perlexpect {
      my($self) = @_;
      $self->_log_message('INFO',"Signing with non-interactive perl Expect script");

      my $pass;
      if ($$self{'gpg_passwd'}) {
         $pass = $$self{'gpg_passwd'};
      } else {
         $pass = `cat $$self{'gpg_passfile'}`;
         chomp($pass);
      }

      my $exp = Expect->spawn('rpm','--addsign',
                              $package{rpmfile},$package{srpmfile});
      $exp->expect(undef, "Enter pass phrase:");
      $exp->send("$pass\n");

      $exp->expect(undef,
                   [ "Pass phrase check failed" => sub { $flag = 1; } ],
                   [ "eof"                      => sub { $flag = 0; } ],
                  );

      return $flag;
   }
}

sub _sign_interactive {
   my($self) = @_;
   $self->_log_message('INFO',"Signing with interactive rpm command");

   my @cmd = ('rpm','--addsign', $package{rpmfile}, $package{srpmfile});

   my $cmd = join(' ',@cmd);
   $self->_log_message('INFO',"Attempting system command: $cmd");

   system(@cmd);
}

# This adds a macro to the rpmmacro file in such a way that at the end, it
# will be restored.
#
sub _add_macro {
   my($self,$file,$macro,$val) = @_;

   if (! -f $file) {

      # If the macros file is new, we'll remove it once we're done.
      $package{'remove'} = 1;


   } elsif ($package{'remove'}  ||  $package{'restore'}) {

      # If we've already created a backup of the macros file
      # which will be restore, or if we've already determined
      # that the macros file will be removed, we don't have
      # redetermine anything.

   } else {

      # This is the first time we're adding a macro to
      # the macros file, so we want to save it so that it
      # can be restored at the end.

      $self->_backup_file($file,"$file.cpantorpm",1);
      $package{'restore'} = 1;

   }

   my $out = new IO::File;
   $out->open(">> $file")  ||
     $self->_log_message('ERR',"Unable to write to .rpmmacros file: $!");
   print $out "\n$macro $val\n";
   $out->close();
}

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

# This will build an RPM/SRPM.

sub _build_rpm {
   my($self) = @_;
   $self->_log_message('HEAD',"Creating RPM: $package{name}");

   #
   # Move the source into the SOURCES directory (as a .tar.gz file)
   #

   my $arch = "$package{topdir}/SOURCES/$package{dir}.tar.gz";
   my $succ = $self->_multiple_methods
     ( [ sub { -f $arch } ],
       ['system','tar',"cd $TMPDIR; {tar} czf $arch $package{dir}"],
       ['module','Archive::Tar', [],
        "my \$tar = new Archive::Tar; \$tar->setcwd($TMPDIR); \$tar->add_files($package{dir}; \$tar->write($arch,COMPRESS_GZIP;"],
     );

   #
   # Figure out how to build RPMs
   #

   my $rpmbuild = $self->_find_exe("rpmbuild");
   if (! $rpmbuild) {

      my $rpm = $self->_find_exe("rpm");
      if (! $rpm) {
         $self->_log_message('ERR','Unable to locate rpmbuild command');
      }

      my @out = `$rpm -ba 2>&1`;
      chomp(@out);
      my @tmp = grep(/unknown option/,@out);
      if (@tmp) {
         $self->_log_message('ERR',
                             'Unable to locate rpm command that supports -ba');
      }

      $rpmbuild = $rpm;
   }

   if ($$self{'no_tests'} == 1) {
      $ENV{'RPMBUILD_NOTESTS'} = 1;
   }

   my @cmd = ($rpmbuild,"-ba",

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

         }
         # The description/summary may contain POD markup (B<text>) that
         # we don't want to interpret as macros.

         if ($var eq 'desc'  ||  $var eq 'summary') {
            $line =~ s/(?:[IBCFS])<(.*?)>/$1/sg;
            $line =~ s/(?:[XZ])<(.*?)>//sg;
            last;
         }
      }

      $line =~ s/\\</</g;
      $line =~ s/\\>/>/g;
      push(@lines,$line);
   }

   foreach my $line (@lines) {
      print $out "$line\n";
   }

   $out->close();
}

sub _post_build {
   my($self) = @_;
   return  if (! $$self{'script_dir'});

   my $script;

   if (-f "$$self{script_dir}/$package{fromsrc}.build-sh") {
      $script = "$$self{script_dir}/$package{fromsrc}.build-sh";

   } else {
      return;
   }

   # Run the script.

   $self->_log_message('INFO',"Post %build script: $script");

   my @cmd = `cat $script`;
   chomp(@cmd);
   $package{'post_build'} = [ @cmd ];
}

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

   $self->_log_message('INFO',"Checking RPM build dir");

   #
   # Check to see if there is a conflict between %_topdir in .rpmmacros
   # file and $$self{rpmbuild} .  We won't use 'rpm --eval' because it's only
   # a conflict if the value in MY rpm macro file differs.
   #

   my $macros = "$ENV{HOME}/.rpmmacros";

   if ($$self{'clean_macros'}) {
      if (-f $macros) {
         $self->_backup_file($macros,"$macros.cpantorpm",0);
         $package{'restore'} = 1;
      }
   }

   my $macroval;
   if (-f $macros) {
      my $in = new IO::File;
      $in->open($macros)  ||
        $self->_log_message('ERR',"Unable to open .rpmmacros file: $!");
      my @in = <$in>;
      $in->close();

      # Multiple %_topdir lines are allowed... last one is used
      my @tmp = grep /^\s*\%_topdir\s+/,@in;
      if (@tmp) {
         my $tmp = pop(@tmp);
         $tmp =~ /^\s*\%_topdir\s+(.*)\s*$/;
         $macroval = $1;

         # If the macro is found and it differs from the one we specified
         # on the command line, we're going to error out.

         if ($$self{'rpmbuild'}  &&  $macroval ne $$self{'rpmbuild'}) {
            $self->_log_message('ERR',
                                'RPM build tree conflict',
                                "   ~/.rpmmacros : $macroval",
                                "   --rpmbuild   : $$self{rpmbuild}",
                                'Use the --clean-macros option to proceed.');
         }
      }
   }

   #
   # If the RPM build dir was specified on the command line (--rpmbuild), but
   # was not found in the macrofile, we'll back up the file and add the
   # %_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");

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

   my ($dist,$vers);
   if ($dir =~ /^(.+)\-(.+)$/) {
      ($dist,$vers) = ($1,$2);
   } else {
      $self->_log_message('ERR','Invalid directory name: $dir');
   }
   $package{'DIR'}  = "$TMPDIR/$dir";
   $package{'dir'}  = $dir;
   $package{'dist'} = $dist;
   $package{'vers'} = $vers;

   # Copy in the directory

   $self->_log_message('INFO',"Copying diretory");
   my $succ = $self->_multiple_methods
     ( [ sub { -d "$TMPDIR/$dir" } ],
       ['module','File::Copy::Recursive',['dircopy'],
        "\$File::Copy::Recursive::CPRFComp = 1; " .
        "dircopy('$$self{file_path}','$TMPDIR')" ],
       ['system','cp',
        "{cp} -r '$$self{file_path}' '$TMPDIR'"],
     );

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

# This takes an archive file containing a package and copies it into
# the temporary directory.  It can use any of the following methods:
#    File::Copy
#    system(cp)
#
sub _get_package_file {
   my($self,$package) = @_;
   my $err;

   $self->_log_message('INFO',"Package type: archive file");

   $package{'from'}    = 'file';
   $package{'fromsrc'} = $package;

   my($valid,$dir,$dist,$vers,$archive,$ext,$filetype) =
     $self->_is_archive($$self{'file_path'});

   if (! $valid) {
      $self->_log_message('ERR',"Package file not a valid archive: $package");
   }
   $package{'DIR'}       = "$TMPDIR/$dir";
   $package{'dir'}       = $dir;
   $package{'dist'}      = $dist;
   $package{'vers'}      = $vers;
   $package{'archive'}   = $archive;
   $package{'ext'}       = $ext;
   $package{'filetype'}  = $filetype;

   # Copy in the file

   $self->_log_message('INFO',"Copying file");

   $self->_backup_file($$self{'file_path'},$TMPDIR,1);

   # Extract it.

   $self->_extract_archive();
}

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

   return  if (! $$self{'patch'}  &&  ! $$self{'patch_dir'});

   my $file;

   if ($$self{'patch'}) {
      $file = $$self{'patch'};

   } elsif (-f "$$self{patch_dir}/$package{fromsrc}.diff") {
      $file = "$$self{patch_dir}/$package{fromsrc}.diff";

   } else {
      return;
   }

   # Run the patch.

   $self->_log_message('INFO',"Applying patch: $file");

   my $patch = $self->_find_exe('patch');
   if (! $patch) {
      $self->_log_message
        ('ERR','patch executable not found when trying to apply patch');
   }
   my $cmd = "cd $package{DIR}; $patch -p0 < $file";
   $self->_log_message('INFO',"Attempting system command: $cmd");

   if (system($cmd) != 0) {
      $self->_log_message('ERR',"pre-package patch failed: $file");
   }
}

sub _run_script {
   my($self) = @_;
   return  if (! $$self{'script'}  &&  ! $$self{'script_dir'});

   my $script;

   if ($$self{'script'}) {
      $script = $$self{'script'};

   } elsif (-f "$$self{script_dir}/$package{fromsrc}.sh") {
      $script = "$$self{script_dir}/$package{fromsrc}.sh";

   } else {
      return;
   }

   # Run the script.

   $self->_log_message('INFO',"Running script: $script");

( run in 1.502 second using v1.01-cache-2.11-cpan-7fcb06a456a )