[Lsb-messages] /var/www/bzr/lsb/devel/repogen r209: Really archive non-symlink files when migrating packages in the FTP dir.
Jeff Licquia
licquia at linuxfoundation.org
Wed Jun 19 21:05:40 UTC 2013
------------------------------------------------------------
revno: 209
committer: Jeff Licquia <licquia at linuxfoundation.org>
branch nick: repogen
timestamp: Wed 2013-06-19 14:05:40 -0700
message:
Really archive non-symlink files when migrating packages in the FTP dir.
modified:
migrate-pkg.hs
-------------- next part --------------
=== modified file 'migrate-pkg.hs'
--- a/migrate-pkg.hs 2013-06-17 20:41:44 +0000
+++ b/migrate-pkg.hs 2013-06-19 21:05:40 +0000
@@ -63,10 +63,28 @@
-- Archive the given file.
+findArchiveDir :: FilePath -> IO (Maybe FilePath)
+findArchiveDir "/" = return Nothing
+findArchiveDir p = do
+ let archivePath = p </> "archive"
+ archiveExist <- doesDirectoryExist archivePath
+ if archiveExist then return $ Just archivePath
+ else findArchiveDir $ takeDirectory p
+
archiveFile :: FilePath -> IO ()
archiveFile f = do
- putStrLn $ "removing " ++ f
- removeFile f
+ symlink <- liftM isSymbolicLink $ getFileStatus f
+ if symlink then do
+ putStrLn $ "removing " ++ f
+ removeFile f
+ else do
+ maybeArchiveDest <- findArchiveDir f
+ if isJust maybeArchiveDest
+ then do
+ let archiveDest = fromJust maybeArchiveDest
+ putStrLn $ "archiving " ++ f ++ " to " ++ archiveDest
+ renameFile f $ archiveDest </> (takeFileName f)
+ else hPutStrLn stderr $ "warning: could not find archive dir, not changing " ++ f
-- Identical packages are equivalent, but we don't want to pick them up.
More information about the lsb-messages
mailing list