mirror of https://codeberg.org/glenneth/stash.git
feat: Comprehensive test suite and documentation update
- Added complete test suite with srfi-64 - Fixed fold-tree implementation in tree module - Renamed canonicalize-path to normalize-path - Resolved module import conflicts - Updated all documentation files - Added proper test infrastructure - Enhanced path handling and tree operations
This commit is contained in:
parent
08f06c6b47
commit
478ba3ae92
|
|
@ -30,7 +30,7 @@
|
||||||
1. Channel Configuration
|
1. Channel Configuration
|
||||||
- Location: `.guix-channel/`
|
- Location: `.guix-channel/`
|
||||||
- Status: Configured for distribution
|
- Status: Configured for distribution
|
||||||
- URL: <https://codeberg.org/glenneth/stash>~~~~
|
- URL: <https://codeberg.org/glenneth/stash>
|
||||||
- Branch: main
|
- Branch: main
|
||||||
|
|
||||||
2. Package Definition
|
2. Package Definition
|
||||||
|
|
@ -76,50 +76,43 @@
|
||||||
- Updated package definition for channel distribution
|
- Updated package definition for channel distribution
|
||||||
- Added minimal-package.scm for local development
|
- Added minimal-package.scm for local development
|
||||||
|
|
||||||
|
3. Testing Improvements
|
||||||
|
- Implemented comprehensive test suite for paths and tree modules
|
||||||
|
- Fixed fold-tree implementation in tree module
|
||||||
|
- Resolved module import conflicts
|
||||||
|
- Fixed declarative module warnings
|
||||||
|
- Added proper test coverage for path normalization
|
||||||
|
- Improved test organization and clarity
|
||||||
|
|
||||||
### Next Steps
|
### Next Steps
|
||||||
|
|
||||||
1. Testing
|
1. Documentation
|
||||||
- Implement comprehensive test suite
|
|
||||||
- Add more test cases for recursive mode
|
|
||||||
|
|
||||||
2. Documentation
|
|
||||||
- Add API documentation for modules
|
- Add API documentation for modules
|
||||||
- Include more advanced usage examples
|
- Include more advanced usage examples
|
||||||
|
|
||||||
3. Features
|
2. Features
|
||||||
- Enhance conflict resolution
|
- Enhance conflict resolution
|
||||||
- Add backup functionality
|
- Add backup functionality
|
||||||
- Improve error reporting
|
- Improve error reporting
|
||||||
|
|
||||||
### Known Issues
|
### Known Issues
|
||||||
|
|
||||||
1. Warnings
|
No major issues currently. All previous warnings have been resolved:
|
||||||
- Intermittent warning about canonicalize-path override
|
- Fixed warning about canonicalize-path override by renaming to normalize-path
|
||||||
- Auto-compilation messages (resolved with GUILE_AUTO_COMPILE=0)
|
- Fixed read-string import conflict in conflict module
|
||||||
|
- Fixed declarative module warning in test runner
|
||||||
|
- Auto-compilation messages resolved with GUILE_AUTO_COMPILE=0
|
||||||
|
|
||||||
### Repository Structure
|
### Repository Structure
|
||||||
|
|
||||||
```sh
|
1. Root Directory
|
||||||
stash/
|
- stash.scm: Main executable
|
||||||
├── .guix-channel/
|
- run-tests.sh: Test runner script
|
||||||
│ └── stash/
|
- .dev-notes.md: Development notes and tracking
|
||||||
│ └── packages/
|
- README.md: Project overview
|
||||||
│ └── stash.scm
|
- USER_GUIDE.md: Detailed user documentation
|
||||||
├── modules/
|
|
||||||
│ └── stash/
|
2. Modules
|
||||||
│ ├── colors.scm
|
- modules/stash/: Core functionality modules
|
||||||
│ ├── conflict.scm
|
- tests/: Test suite and helpers
|
||||||
│ ├── file-ops.scm
|
- .guix-channel/: Guix distribution configuration
|
||||||
│ ├── help.scm
|
|
||||||
│ ├── log.scm
|
|
||||||
│ ├── package.scm
|
|
||||||
│ ├── paths.scm
|
|
||||||
│ └── tree.scm
|
|
||||||
├── test-source/
|
|
||||||
├── .gitignore
|
|
||||||
├── README.md
|
|
||||||
├── USER_GUIDE.md
|
|
||||||
├── channels.scm.example
|
|
||||||
├── minimal-package.scm
|
|
||||||
└── stash.scm
|
|
||||||
```
|
|
||||||
|
|
|
||||||
108
DEVLOG.md
108
DEVLOG.md
|
|
@ -22,41 +22,48 @@ The project is organized into several modules:
|
||||||
|
|
||||||
## Recent Changes
|
## Recent Changes
|
||||||
|
|
||||||
|
### Testing Infrastructure
|
||||||
|
|
||||||
|
- Implemented comprehensive test suite with srfi-64
|
||||||
|
- Added test-helpers module for common test operations
|
||||||
|
- Created test cases for all core modules
|
||||||
|
- Fixed test runner to use primitive-load for better module handling
|
||||||
|
- Added proper cleanup of test directories
|
||||||
|
|
||||||
### Path Handling Improvements
|
### Path Handling Improvements
|
||||||
|
|
||||||
- Enhanced `canonicalize-path` function to handle:
|
- Renamed `canonicalize-path` to `normalize-path` for clarity
|
||||||
|
- Enhanced path normalization to handle:
|
||||||
- Dot (.) and dot-dot (..) notation
|
- Dot (.) and dot-dot (..) notation
|
||||||
- Home directory expansion (~)
|
- Home directory expansion (~)
|
||||||
- Absolute and relative paths
|
- Absolute and relative paths
|
||||||
- Improved path resolution for both dot syntax and explicit paths
|
- Redundant path separators
|
||||||
|
- Improved path comparison with proper normalization
|
||||||
|
- Added robust path resolution for symlinks
|
||||||
|
|
||||||
### Symlink Creation
|
### Tree Operations Enhancement
|
||||||
|
|
||||||
- Rewrote `plan-operations` function to handle:
|
- Implemented efficient tree traversal with `fold-tree`
|
||||||
- Dot syntax (stash .)
|
- Added proper directory scanning with ignore patterns
|
||||||
- Explicit source/target paths
|
- Improved symlink planning with cycle detection
|
||||||
- Fixed symlink creation to maintain correct directory structure
|
- Enhanced tree comparison functionality
|
||||||
- Added support for creating parent directories as needed
|
- Added support for recursive operations
|
||||||
|
- Fixed directory structure preservation
|
||||||
|
|
||||||
### Package Management
|
### Module Organization
|
||||||
|
|
||||||
- Implemented package record type for managing:
|
- Resolved import conflicts between modules
|
||||||
- Package name
|
- Fixed warnings about duplicate bindings
|
||||||
- Source path
|
- Improved module interface consistency
|
||||||
- Target path
|
- Enhanced error handling and reporting
|
||||||
- Ignore patterns
|
- Added proper documentation strings
|
||||||
- Added support for reading ignore patterns from:
|
|
||||||
- .stash-local-ignore
|
|
||||||
- .stash-global-ignore
|
|
||||||
|
|
||||||
### Testing
|
### Distribution
|
||||||
|
|
||||||
- Added comprehensive test suite
|
- Configured Guix channel for distribution
|
||||||
- Implemented test cases for:
|
- Updated package definition
|
||||||
- Dot syntax stashing
|
- Added proper version tracking
|
||||||
- Explicit path stashing
|
- Improved installation documentation
|
||||||
- Path resolution
|
|
||||||
- Symlink creation
|
|
||||||
|
|
||||||
## Current Operation
|
## Current Operation
|
||||||
|
|
||||||
|
|
@ -92,37 +99,36 @@ Stash now supports three main modes of operation:
|
||||||
- Interactively prompts for target directory
|
- Interactively prompts for target directory
|
||||||
- Ideal for first-time users and exploratory stashing
|
- Ideal for first-time users and exploratory stashing
|
||||||
|
|
||||||
### Symlink Creation Process
|
### Tree Traversal Process
|
||||||
|
|
||||||
1. Determines source and target paths
|
1. Scans source directory recursively
|
||||||
2. Creates parent directories if needed
|
2. Builds tree representation
|
||||||
3. Removes existing symlink/directory if present
|
3. Applies ignore patterns
|
||||||
4. Creates new symlink pointing to correct location
|
4. Plans symlink operations
|
||||||
|
5. Validates tree structure
|
||||||
|
6. Creates necessary symlinks
|
||||||
|
|
||||||
### Path Resolution
|
### Error Handling
|
||||||
|
|
||||||
- Handles both absolute and relative paths
|
- Detects circular symlinks
|
||||||
- Expands home directory references
|
- Validates path existence
|
||||||
- Resolves dot and dot-dot notation
|
- Checks permissions
|
||||||
- Maintains correct directory structure
|
- Handles conflicts gracefully
|
||||||
|
- Provides detailed error messages
|
||||||
|
|
||||||
## Known Issues
|
## Next Steps
|
||||||
|
|
||||||
- Warning about overriding core binding `canonicalize-path`
|
1. API Documentation
|
||||||
- This is expected behavior and doesn't affect functionality
|
- Document module interfaces
|
||||||
- Could be addressed in future by renaming the function
|
- Add usage examples
|
||||||
|
- Create API reference
|
||||||
|
|
||||||
## Future Plans
|
2. Feature Enhancements
|
||||||
|
- Add backup functionality
|
||||||
|
- Enhance conflict resolution
|
||||||
|
- Improve error reporting
|
||||||
|
|
||||||
1. Implement more robust conflict resolution
|
3. Performance Optimization
|
||||||
2. Add comprehensive documentation
|
- Profile tree operations
|
||||||
3. Optimize path handling
|
- Optimize path handling
|
||||||
4. Address module import warnings
|
- Improve memory usage
|
||||||
5. Add user configuration options
|
|
||||||
6. Enhance cross-platform support
|
|
||||||
|
|
||||||
## Dependencies
|
|
||||||
|
|
||||||
- Guile Scheme 3.0.9
|
|
||||||
- Standard Guile libraries
|
|
||||||
- Custom modules for path handling and file operations
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,57 @@
|
||||||
|
.PHONY: test test-paths test-package test-tree test-file-ops test-conflict clean-test
|
||||||
|
|
||||||
|
# Set up environment
|
||||||
|
export GUILE_LOAD_PATH := $(PWD):$(GUILE_LOAD_PATH)
|
||||||
|
|
||||||
|
# Default target
|
||||||
|
test: clean-test
|
||||||
|
@echo "Running all tests..."
|
||||||
|
@./run-tests.sh
|
||||||
|
|
||||||
|
# Individual test targets
|
||||||
|
test-paths:
|
||||||
|
@echo "Running path tests..."
|
||||||
|
@guile tests/paths-test.scm
|
||||||
|
|
||||||
|
test-package:
|
||||||
|
@echo "Running package tests..."
|
||||||
|
@guile tests/package-test.scm
|
||||||
|
|
||||||
|
test-tree:
|
||||||
|
@echo "Running tree tests..."
|
||||||
|
@guile tests/tree-test.scm
|
||||||
|
|
||||||
|
test-file-ops:
|
||||||
|
@echo "Running file operations tests..."
|
||||||
|
@guile tests/file-ops-test.scm
|
||||||
|
|
||||||
|
test-conflict:
|
||||||
|
@echo "Running conflict tests..."
|
||||||
|
@guile tests/conflict-test.scm
|
||||||
|
|
||||||
|
# Clean temporary test files
|
||||||
|
clean-test:
|
||||||
|
@echo "Cleaning test files..."
|
||||||
|
@rm -f tests/*.log
|
||||||
|
@rm -rf /tmp/stash-test-*
|
||||||
|
|
||||||
|
# Show test coverage (requires guile-coverage)
|
||||||
|
coverage:
|
||||||
|
@echo "Generating test coverage report..."
|
||||||
|
@GUILE_LOAD_PATH="$(PWD):$$GUILE_LOAD_PATH" \
|
||||||
|
guile --coverage tests/run-tests.scm
|
||||||
|
@lcov --capture --directory . --output-file coverage.info
|
||||||
|
@genhtml coverage.info --output-directory coverage
|
||||||
|
|
||||||
|
.PHONY: help
|
||||||
|
help:
|
||||||
|
@echo "Available targets:"
|
||||||
|
@echo " test - Run all tests"
|
||||||
|
@echo " test-paths - Run path handling tests"
|
||||||
|
@echo " test-package - Run package management tests"
|
||||||
|
@echo " test-tree - Run tree operation tests"
|
||||||
|
@echo " test-file-ops- Run file operation tests"
|
||||||
|
@echo " test-conflict- Run conflict resolution tests"
|
||||||
|
@echo " clean-test - Clean temporary test files"
|
||||||
|
@echo " coverage - Generate test coverage report"
|
||||||
|
@echo " help - Show this help message"
|
||||||
62
README.md
62
README.md
|
|
@ -4,27 +4,39 @@
|
||||||
|
|
||||||
## Installation
|
## Installation
|
||||||
|
|
||||||
There are two ways to install Stash:
|
### Using Guix (Recommended)
|
||||||
|
|
||||||
### Method 1: Using Guix (Recommended)
|
1. Add the Stash channel to your `~/.config/guix/channels.scm`:
|
||||||
|
|
||||||
|
```scheme
|
||||||
|
(cons* (channel
|
||||||
|
(name 'stash)
|
||||||
|
(url "https://codeberg.org/glenneth/stash")
|
||||||
|
(branch "main"))
|
||||||
|
%default-channels)
|
||||||
|
```
|
||||||
|
|
||||||
|
2. Update your channels and install:
|
||||||
|
|
||||||
```sh
|
```sh
|
||||||
# Install from the local package definition
|
guix pull
|
||||||
guix package --install-from-file=minimal-package.scm
|
guix install stash
|
||||||
|
```
|
||||||
|
|
||||||
# Configure your shell environment:
|
3. Configure your shell environment:
|
||||||
|
|
||||||
|
```sh
|
||||||
# For Fish shell (add to ~/.config/fish/config.fish):
|
# For Fish shell (add to ~/.config/fish/config.fish):
|
||||||
set -gx GUIX_PROFILE $HOME/.guix-profile
|
set -gx GUIX_PROFILE $HOME/.guix-profile
|
||||||
set -gx PATH $GUIX_PROFILE/bin $PATH
|
set -gx PATH $GUIX_PROFILE/bin $PATH
|
||||||
|
|
||||||
# For Bash (add to ~/.bashrc):
|
# For Bash (add to ~/.bashrc):
|
||||||
export GUIX_PROFILE="$HOME/.guix-profile"
|
export GUIX_PROFILE=$HOME/.guix-profile
|
||||||
. "$GUIX_PROFILE/etc/profile"
|
export PATH=$GUIX_PROFILE/bin:$PATH
|
||||||
|
|
||||||
# For Zsh (add to ~/.zshrc):
|
# For Zsh (add to ~/.zshrc):
|
||||||
export GUIX_PROFILE="$HOME/.guix-profile"
|
export GUIX_PROFILE=$HOME/.guix-profile
|
||||||
. "$GUIX_PROFILE/etc/profile"
|
export PATH=$GUIX_PROFILE/bin:$PATH
|
||||||
```
|
```
|
||||||
|
|
||||||
### Method 2: Manual Installation
|
### Method 2: Manual Installation
|
||||||
|
|
@ -170,21 +182,27 @@ Default ignore patterns:
|
||||||
|
|
||||||
```sh
|
```sh
|
||||||
stash/
|
stash/
|
||||||
├── stash.scm # Main entry point
|
├── .guix-channel/ # Guix channel configuration
|
||||||
|
│ └── stash/
|
||||||
|
│ └── packages/
|
||||||
|
│ └── stash.scm
|
||||||
├── modules/
|
├── modules/
|
||||||
│ └── stash/
|
│ └── stash/
|
||||||
│ ├── paths.scm # Path handling
|
│ ├── colors.scm # Terminal colors
|
||||||
│ ├── tree.scm # Tree operations
|
│ ├── conflict.scm # Conflict resolution
|
||||||
│ ├── package.scm # Package management
|
│ ├── file-ops.scm # File operations
|
||||||
│ ├── file-ops.scm # File operations
|
│ ├── help.scm # Help messages
|
||||||
│ ├── log.scm # Logging
|
│ ├── log.scm # Logging utilities
|
||||||
│ ├── conflict.scm # Conflict resolution
|
│ ├── package.scm # Package information
|
||||||
│ ├── colors.scm # Terminal colors
|
│ ├── paths.scm # Path manipulation
|
||||||
│ └── help.scm # Help messages
|
│ └── tree.scm # Directory tree handling
|
||||||
├── README.md # Project overview
|
├── tests/ # Test suite
|
||||||
├── USER-GUIDE.md # Comprehensive user documentation
|
│ ├── run-tests.sh
|
||||||
├── DEVLOG.md # Development log
|
│ ├── test-helpers.scm
|
||||||
└── LICENSE # GNU GPL v3
|
│ └── *-test.scm # Individual test files
|
||||||
|
├── README.md # Project overview
|
||||||
|
├── USER_GUIDE.md # Comprehensive documentation
|
||||||
|
└── stash.scm # Main executable
|
||||||
```
|
```
|
||||||
|
|
||||||
## Dependencies
|
## Dependencies
|
||||||
|
|
|
||||||
|
|
@ -208,28 +208,39 @@ stash --source ~/Videos --target /media/external/videos --recursive
|
||||||
|
|
||||||
### 1. Path Handling
|
### 1. Path Handling
|
||||||
|
|
||||||
- Supports home directory expansion (~)
|
Stash provides robust path handling capabilities:
|
||||||
- Handles both absolute and relative paths
|
|
||||||
- Maintains directory structure in target location
|
|
||||||
|
|
||||||
### 2. Symlink Management
|
- Supports home directory expansion (`~`)
|
||||||
|
- Handles relative paths intelligently
|
||||||
|
- Normalizes paths for consistent comparison
|
||||||
|
- Resolves symbolic links when needed
|
||||||
|
- Maintains proper path relationships in recursive operations
|
||||||
|
|
||||||
- Creates intermediate directories as needed
|
The path normalization ensures that:
|
||||||
- Handles existing symlinks gracefully
|
- Redundant path separators are removed
|
||||||
- Preserves original file permissions
|
- Parent directory references (`..`) are resolved
|
||||||
|
- Current directory references (`.`) are removed
|
||||||
|
- Paths are made relative when appropriate
|
||||||
|
- Symlinks are handled correctly in comparisons
|
||||||
|
|
||||||
### 3. Ignore Patterns
|
### 2. Directory Tree Operations
|
||||||
|
|
||||||
- Create `.stashignore` in source directory
|
Stash includes sophisticated directory tree handling:
|
||||||
- Add patterns similar to `.gitignore`
|
|
||||||
|
|
||||||
```sh
|
- Recursive directory scanning
|
||||||
*.tmp
|
- Efficient tree traversal
|
||||||
.DS_Store
|
- Intelligent ignore patterns (e.g., `.git/`, `*.bak`)
|
||||||
node_modules/
|
- Proper symlink planning and creation
|
||||||
```
|
- Conflict detection and resolution
|
||||||
|
|
||||||
### 4. Conflict Resolution
|
The tree operations ensure:
|
||||||
|
- All file relationships are preserved
|
||||||
|
- Circular symlinks are prevented
|
||||||
|
- Existing symlinks are handled appropriately
|
||||||
|
- Conflicts are detected early
|
||||||
|
- Directory structures are maintained
|
||||||
|
|
||||||
|
### 3. Conflict Resolution
|
||||||
|
|
||||||
- Automatically detects existing files/symlinks
|
- Automatically detects existing files/symlinks
|
||||||
- Interactive prompts for resolution
|
- Interactive prompts for resolution
|
||||||
|
|
|
||||||
|
|
@ -1,60 +1,57 @@
|
||||||
;; stash-conflict.scm --- Conflict resolution module for Stash
|
;; stash-conflict.scm --- Conflict resolution module for Stash
|
||||||
|
|
||||||
;; (define-module (stash conflict)
|
|
||||||
;; #:export (prompt-user-for-action handle-conflict))
|
|
||||||
|
|
||||||
;; ;; Import necessary modules
|
|
||||||
;; (use-modules (ice-9 rdelim)) ;; Import read-line function for reading user input
|
|
||||||
|
|
||||||
;; ;;; Conflict resolution handler with user options
|
|
||||||
;; (define (prompt-user-for-action)
|
|
||||||
;; "Prompt the user to decide how to handle a conflict: overwrite (o), skip (s), or cancel (c)."
|
|
||||||
;; (display "A conflict was detected. Choose action - Overwrite (o), Skip (s), or Cancel (c): ")
|
|
||||||
;; (let ((response (read-line)))
|
|
||||||
;; (cond
|
|
||||||
;; ((string-ci=? response "o") 'overwrite)
|
|
||||||
;; ((string-ci=? response "s") 'skip)
|
|
||||||
;; ((string-ci=? response "c") 'cancel)
|
|
||||||
;; (else
|
|
||||||
;; (display "Invalid input. Please try again.\n")
|
|
||||||
;; (prompt-user-for-action)))))
|
|
||||||
|
|
||||||
;; ;;; Helper function to handle conflicts
|
|
||||||
;; (define (handle-conflict target-source-dir source-dir delete-directory log-action)
|
|
||||||
;; "Handle conflicts when the target directory already exists."
|
|
||||||
;; (let ((choice (prompt-user-for-action)))
|
|
||||||
;; (cond
|
|
||||||
;; ((eq? choice 'overwrite)
|
|
||||||
;; (delete-directory target-source-dir)
|
|
||||||
;; (rename-file source-dir target-source-dir)
|
|
||||||
;; (display (format #f "Overwriting directory ~a.\n" target-source-dir))
|
|
||||||
;; (log-action (format #f "Overwritten directory: ~a" target-source-dir)))
|
|
||||||
;; ((eq? choice 'skip)
|
|
||||||
;; (display "Skipping move operation.\n")
|
|
||||||
;; (log-action (format #f "Skipped moving directory: ~a" target-source-dir)))
|
|
||||||
;; ((eq? choice 'cancel)
|
|
||||||
;; (display "Operation cancelled by user.\n")
|
|
||||||
;; (log-action "Operation cancelled by user.")
|
|
||||||
;; (exit 0)))))
|
|
||||||
|
|
||||||
(define-module (stash conflict)
|
(define-module (stash conflict)
|
||||||
#:export (prompt-user-for-action handle-conflict))
|
#:use-module (ice-9 ftw)
|
||||||
|
#:use-module (ice-9 rdelim) ;; For read-string
|
||||||
|
#:use-module (stash paths) ;; For canonicalize-path
|
||||||
|
#:export (has-conflict?
|
||||||
|
resolve-conflict
|
||||||
|
prompt-user-for-action
|
||||||
|
handle-conflict))
|
||||||
|
|
||||||
;; Import necessary modules
|
;; Import necessary modules
|
||||||
(use-modules (ice-9 rdelim)
|
(use-modules (ice-9 rdelim)) ;; Import read-line function for reading user input
|
||||||
(stash colors)) ;; Import the colors module
|
|
||||||
|
(define (copy-file-contents source target)
|
||||||
|
"Copy contents from source file to target file"
|
||||||
|
(let ((content (with-input-from-file source read-string)))
|
||||||
|
(with-output-to-file target
|
||||||
|
(lambda () (display content)))))
|
||||||
|
|
||||||
|
(define (has-conflict? source target)
|
||||||
|
"Check if there would be a conflict when moving source to target"
|
||||||
|
(and (file-exists? target)
|
||||||
|
(not (equal? (canonicalize-path source)
|
||||||
|
(canonicalize-path target)))))
|
||||||
|
|
||||||
|
(define (resolve-conflict source target strategy)
|
||||||
|
"Resolve a conflict between source and target using the specified strategy"
|
||||||
|
(case strategy
|
||||||
|
((backup)
|
||||||
|
(let ((backup-path (string-append target ".bak")))
|
||||||
|
(rename-file target backup-path)
|
||||||
|
(copy-file-contents source target)
|
||||||
|
#t))
|
||||||
|
((overwrite)
|
||||||
|
(when (file-exists? target)
|
||||||
|
(delete-file target))
|
||||||
|
(copy-file-contents source target)
|
||||||
|
#t)
|
||||||
|
((skip)
|
||||||
|
#t)
|
||||||
|
(else #f)))
|
||||||
|
|
||||||
;;; Conflict resolution handler with user options
|
;;; Conflict resolution handler with user options
|
||||||
(define (prompt-user-for-action)
|
(define (prompt-user-for-action)
|
||||||
"Prompt the user to decide how to handle a conflict: overwrite (o), skip (s), or cancel (c)."
|
"Prompt the user to decide how to handle a conflict: overwrite (o), skip (s), or cancel (c)."
|
||||||
(display (color-message "A conflict was detected. Choose action - Overwrite (o), Skip (s), or Cancel (c): " yellow-text)) ;; Yellow for prompt
|
(display "A conflict was detected. Choose action - Overwrite (o), Skip (s), or Cancel (c): ")
|
||||||
(let ((response (read-line)))
|
(let ((response (read-line)))
|
||||||
(cond
|
(cond
|
||||||
((string-ci=? response "o") 'overwrite)
|
((string-ci=? response "o") 'overwrite)
|
||||||
((string-ci=? response "s") 'skip)
|
((string-ci=? response "s") 'skip)
|
||||||
((string-ci=? response "c") 'cancel)
|
((string-ci=? response "c") 'cancel)
|
||||||
(else
|
(else
|
||||||
(display (color-message "Invalid input. Please try again.\n" red-text)) ;; Red for invalid input
|
(display "Invalid input. Please try again.\n")
|
||||||
(prompt-user-for-action)))))
|
(prompt-user-for-action)))))
|
||||||
|
|
||||||
;;; Helper function to handle conflicts
|
;;; Helper function to handle conflicts
|
||||||
|
|
@ -65,12 +62,12 @@
|
||||||
((eq? choice 'overwrite)
|
((eq? choice 'overwrite)
|
||||||
(delete-directory target-source-dir)
|
(delete-directory target-source-dir)
|
||||||
(rename-file source-dir target-source-dir)
|
(rename-file source-dir target-source-dir)
|
||||||
(display (color-message (format #f "Overwriting directory ~a.\n" target-source-dir) green-text)) ;; Green for success
|
(display (format #f "Overwriting directory ~a.\n" target-source-dir))
|
||||||
(log-action (format #f "Overwritten directory: ~a" target-source-dir)))
|
(log-action (format #f "Overwritten directory: ~a" target-source-dir)))
|
||||||
((eq? choice 'skip)
|
((eq? choice 'skip)
|
||||||
(display (color-message "Skipping move operation.\n" green-text)) ;; Green for skipping
|
(display "Skipping move operation.\n")
|
||||||
(log-action (format #f "Skipped moving directory: ~a" target-source-dir)))
|
(log-action (format #f "Skipped moving directory: ~a" target-source-dir)))
|
||||||
((eq? choice 'cancel)
|
((eq? choice 'cancel)
|
||||||
(display (color-message "Operation cancelled by user.\n" yellow-text)) ;; Yellow for cancel
|
(display "Operation cancelled by user.\n")
|
||||||
(log-action "Operation cancelled by user.")
|
(log-action "Operation cancelled by user.")
|
||||||
(exit 0)))))
|
(exit 0)))))
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,22 @@
|
||||||
#:use-module (stash log) ;; Import log-action, current-timestamp
|
#:use-module (stash log) ;; Import log-action, current-timestamp
|
||||||
#:use-module (stash paths) ;; Import expand-home, concat-path, ensure-config-path
|
#:use-module (stash paths) ;; Import expand-home, concat-path, ensure-config-path
|
||||||
#:use-module (stash conflict) ;; Import prompt-user-for-action, handle-conflict
|
#:use-module (stash conflict) ;; Import prompt-user-for-action, handle-conflict
|
||||||
#:export (move-source-to-target create-symlink delete-directory mkdir-p execute-operations file-is-symlink?))
|
#:use-module (ice-9 ftw) ;; For file tree walk
|
||||||
|
#:export (move-source-to-target
|
||||||
|
create-symlink
|
||||||
|
delete-directory
|
||||||
|
mkdir-p
|
||||||
|
execute-operations
|
||||||
|
file-is-symlink?
|
||||||
|
ensure-directory
|
||||||
|
copy-recursive
|
||||||
|
delete-recursive
|
||||||
|
make-file-executable
|
||||||
|
make-file-readable
|
||||||
|
file-is-executable?
|
||||||
|
file-is-readable?
|
||||||
|
resolve-symlink
|
||||||
|
update-symlink))
|
||||||
|
|
||||||
;;; Helper function to quote shell arguments
|
;;; Helper function to quote shell arguments
|
||||||
(define (shell-quote-argument arg)
|
(define (shell-quote-argument arg)
|
||||||
|
|
@ -54,14 +69,14 @@
|
||||||
;;; Helper function to create a symlink
|
;;; Helper function to create a symlink
|
||||||
(define (create-symlink source target)
|
(define (create-symlink source target)
|
||||||
"Create a symlink from source to target."
|
"Create a symlink from source to target."
|
||||||
(when (file-exists? source)
|
(when (file-exists? target)
|
||||||
(delete-file source))
|
(delete-file target))
|
||||||
(let ((source-dir (dirname source)))
|
(let ((target-dir (dirname target)))
|
||||||
(when (not (file-exists? source-dir))
|
(when (not (file-exists? target-dir))
|
||||||
(mkdir-p source-dir)))
|
(mkdir-p target-dir)))
|
||||||
(format #t "Creating symlink: ~a -> ~a~%" source target)
|
(format #t "Creating symlink: ~a -> ~a~%" target source)
|
||||||
(symlink target source)
|
(symlink source target)
|
||||||
(log-action (format #f "Created symlink ~a -> ~a" source target)))
|
(log-action (format #f "Created symlink ~a -> ~a" target source)))
|
||||||
|
|
||||||
;;; Helper function to check if a path is a symlink
|
;;; Helper function to check if a path is a symlink
|
||||||
(define (file-is-symlink? path)
|
(define (file-is-symlink? path)
|
||||||
|
|
@ -94,9 +109,65 @@
|
||||||
(else (display (format #f "Unknown operation: ~a\n" op)))))
|
(else (display (format #f "Unknown operation: ~a\n" op)))))
|
||||||
operations))
|
operations))
|
||||||
|
|
||||||
|
;; File permission constants
|
||||||
|
(define read-permission #o444)
|
||||||
|
(define execute-permission #o111)
|
||||||
|
|
||||||
|
(define (ensure-directory dir)
|
||||||
|
"Create directory if it doesn't exist"
|
||||||
|
(when (not (file-exists? dir))
|
||||||
|
(mkdir-p dir)))
|
||||||
|
|
||||||
|
(define (copy-recursive source target)
|
||||||
|
"Copy directory recursively"
|
||||||
|
(system (string-append "cp -R " (shell-quote-argument source) " " (shell-quote-argument target))))
|
||||||
|
|
||||||
|
(define (delete-recursive path)
|
||||||
|
"Delete file or directory recursively"
|
||||||
|
(system (string-append "rm -rf " (shell-quote-argument path))))
|
||||||
|
|
||||||
|
(define (make-file-executable path)
|
||||||
|
"Make file executable"
|
||||||
|
(chmod path (logior (stat:mode (stat path)) execute-permission)))
|
||||||
|
|
||||||
|
(define (make-file-readable path)
|
||||||
|
"Make file readable"
|
||||||
|
(chmod path (logior (stat:mode (stat path)) read-permission)))
|
||||||
|
|
||||||
|
(define (file-is-executable? path)
|
||||||
|
"Check if file is executable"
|
||||||
|
(let ((mode (stat:mode (stat path))))
|
||||||
|
(not (zero? (logand mode execute-permission)))))
|
||||||
|
|
||||||
|
(define (file-is-readable? path)
|
||||||
|
"Check if file is readable"
|
||||||
|
(let ((mode (stat:mode (stat path))))
|
||||||
|
(not (zero? (logand mode read-permission)))))
|
||||||
|
|
||||||
|
(define (resolve-symlink path)
|
||||||
|
"Resolve symlink to its target"
|
||||||
|
(if (file-is-symlink? path)
|
||||||
|
(readlink path)
|
||||||
|
path))
|
||||||
|
|
||||||
|
(define (update-symlink target link)
|
||||||
|
"Update or create symlink"
|
||||||
|
(when (file-exists? link)
|
||||||
|
(delete-file link))
|
||||||
|
(symlink target link))
|
||||||
|
|
||||||
;;; Export list
|
;;; Export list
|
||||||
(export mkdir-p
|
(export mkdir-p
|
||||||
execute-operations
|
execute-operations
|
||||||
move-source-to-target
|
move-source-to-target
|
||||||
create-symlink
|
create-symlink
|
||||||
file-is-symlink?)
|
file-is-symlink?
|
||||||
|
ensure-directory
|
||||||
|
copy-recursive
|
||||||
|
delete-recursive
|
||||||
|
make-file-executable
|
||||||
|
make-file-readable
|
||||||
|
file-is-executable?
|
||||||
|
file-is-readable?
|
||||||
|
resolve-symlink
|
||||||
|
update-symlink)
|
||||||
|
|
|
||||||
|
|
@ -10,28 +10,29 @@
|
||||||
(let ((current-time (current-date)))
|
(let ((current-time (current-date)))
|
||||||
(date->string current-time "~Y-~m-~d ~H:~M:~S")))
|
(date->string current-time "~Y-~m-~d ~H:~M:~S")))
|
||||||
|
|
||||||
;; Log an action with timestamp
|
|
||||||
(define (log-action message)
|
|
||||||
(let ((log-dir (string-append (getenv "HOME") "/.local/share/stash"))
|
|
||||||
(log-file "stash.log"))
|
|
||||||
;; Create log directory if it doesn't exist
|
|
||||||
(when (not (file-exists? log-dir))
|
|
||||||
(mkdir-p log-dir))
|
|
||||||
;; Append message to log file
|
|
||||||
(call-with-output-file (string-append log-dir "/" log-file)
|
|
||||||
(lambda (port)
|
|
||||||
(format port "[~a] ~a~%" (current-timestamp) message))
|
|
||||||
#:append #t)))
|
|
||||||
|
|
||||||
;; Helper function to create directory and parents
|
;; Helper function to create directory and parents
|
||||||
(define (mkdir-p dir)
|
(define (mkdir-p dir)
|
||||||
(let loop ((components (string-split dir #\/))
|
(let loop ((components (filter (lambda (x) (not (string-null? x)))
|
||||||
(path ""))
|
(string-split dir #\/)))
|
||||||
|
(path (if (string-prefix? "/" dir) "/" "")))
|
||||||
(when (not (null? components))
|
(when (not (null? components))
|
||||||
(let ((new-path (if (string-null? path)
|
(let ((new-path (if (string=? path "/")
|
||||||
(car components)
|
(string-append path (car components))
|
||||||
(string-append path "/" (car components)))))
|
(if (string-null? path)
|
||||||
(when (and (not (string-null? new-path))
|
(car components)
|
||||||
|
(string-append path "/" (car components))))))
|
||||||
|
(when (and (not (string=? new-path "/"))
|
||||||
(not (file-exists? new-path)))
|
(not (file-exists? new-path)))
|
||||||
(mkdir new-path #o755))
|
(mkdir new-path #o755))
|
||||||
(loop (cdr components) new-path)))))
|
(loop (cdr components) new-path)))))
|
||||||
|
|
||||||
|
;; Log an action with timestamp
|
||||||
|
(define (log-action message)
|
||||||
|
(let* ((log-dir (string-append (getenv "HOME") "/.local/share/stash"))
|
||||||
|
(log-file (string-append log-dir "/stash.log")))
|
||||||
|
;; Create log directory if it doesn't exist
|
||||||
|
(mkdir-p log-dir)
|
||||||
|
;; Append message to log file
|
||||||
|
(let ((port (open-file log-file "a")))
|
||||||
|
(format port "[~a] ~a~%" (current-timestamp) message)
|
||||||
|
(close-port port))))
|
||||||
|
|
|
||||||
|
|
@ -7,19 +7,43 @@
|
||||||
#:export (make-package
|
#:export (make-package
|
||||||
package?
|
package?
|
||||||
package-name
|
package-name
|
||||||
package-path
|
package-source
|
||||||
package-target
|
package-target
|
||||||
package-ignore-patterns
|
package-ignores
|
||||||
read-ignore-patterns))
|
read-ignore-patterns
|
||||||
|
should-include-file?
|
||||||
|
package-exists?
|
||||||
|
scan-package-files))
|
||||||
|
|
||||||
;; Package record type
|
;; Package record type
|
||||||
(define-record-type <package>
|
(define-record-type <package>
|
||||||
(make-package name path target ignore-patterns)
|
(make-package name source target ignores)
|
||||||
package?
|
package?
|
||||||
(name package-name)
|
(name package-name)
|
||||||
(path package-path)
|
(source package-source)
|
||||||
(target package-target)
|
(target package-target)
|
||||||
(ignore-patterns package-ignore-patterns))
|
(ignores package-ignores))
|
||||||
|
|
||||||
|
;; Convert glob pattern to regex pattern
|
||||||
|
(define (glob->regex pattern)
|
||||||
|
(let ((len (string-length pattern)))
|
||||||
|
(if (= len 0)
|
||||||
|
"^$"
|
||||||
|
(let loop ((i 0) (result "^"))
|
||||||
|
(if (= i len)
|
||||||
|
(string-append result
|
||||||
|
(if (char=? (string-ref pattern (- len 1)) #\/)
|
||||||
|
".*"
|
||||||
|
"$"))
|
||||||
|
(let ((c (string-ref pattern i)))
|
||||||
|
(loop (+ i 1)
|
||||||
|
(string-append result
|
||||||
|
(case c
|
||||||
|
((#\*) ".*")
|
||||||
|
((#\?) ".")
|
||||||
|
((#\. #\$ #\^ #\[ #\] #\( #\) #\| #\+ #\\)
|
||||||
|
(string-append "\\" (string c)))
|
||||||
|
(else (string c)))))))))))
|
||||||
|
|
||||||
;; Read ignore patterns from .stash-local-ignore and .stash-global-ignore
|
;; Read ignore patterns from .stash-local-ignore and .stash-global-ignore
|
||||||
(define (read-ignore-patterns package-path)
|
(define (read-ignore-patterns package-path)
|
||||||
|
|
@ -44,6 +68,50 @@
|
||||||
|
|
||||||
;; Check if a path should be ignored based on patterns
|
;; Check if a path should be ignored based on patterns
|
||||||
(define (should-ignore? path patterns)
|
(define (should-ignore? path patterns)
|
||||||
|
(format #t "Checking path: ~a against patterns: ~a~%" path patterns)
|
||||||
(any (lambda (pattern)
|
(any (lambda (pattern)
|
||||||
(string-match pattern path))
|
(let ((regex (glob->regex pattern)))
|
||||||
|
(format #t " Pattern: ~a -> Regex: ~a~%" pattern regex)
|
||||||
|
(string-match regex path)))
|
||||||
patterns))
|
patterns))
|
||||||
|
|
||||||
|
;; Check if a file should be included based on package ignore patterns
|
||||||
|
(define (should-include-file? pkg path)
|
||||||
|
(let* ((rel-path (string-drop path (string-length (package-source pkg))))
|
||||||
|
;; Remove leading slash for pattern matching
|
||||||
|
(normalized-path (if (string-prefix? "/" rel-path)
|
||||||
|
(string-drop rel-path 1)
|
||||||
|
rel-path))
|
||||||
|
(patterns (package-ignores pkg)))
|
||||||
|
(format #t "Checking file: ~a (rel: ~a, normalized: ~a)~%" path rel-path normalized-path)
|
||||||
|
(not (should-ignore? normalized-path patterns))))
|
||||||
|
|
||||||
|
;; Check if package directory exists
|
||||||
|
(define (package-exists? pkg)
|
||||||
|
(file-exists? (package-source pkg)))
|
||||||
|
|
||||||
|
;; Scan package files recursively
|
||||||
|
(define (scan-package-files pkg)
|
||||||
|
(let ((source (package-source pkg)))
|
||||||
|
(if (not (file-exists? source))
|
||||||
|
'()
|
||||||
|
(let ((files '()))
|
||||||
|
(file-system-fold
|
||||||
|
(lambda (path stat result) ; enter?
|
||||||
|
(should-include-file? pkg path))
|
||||||
|
(lambda (path stat result) ; leaf
|
||||||
|
(when (should-include-file? pkg path)
|
||||||
|
(set! files (cons path files)))
|
||||||
|
result)
|
||||||
|
(lambda (path stat result) ; down
|
||||||
|
result)
|
||||||
|
(lambda (path stat result) ; up
|
||||||
|
result)
|
||||||
|
(lambda (path stat result) ; skip
|
||||||
|
result)
|
||||||
|
(lambda (path stat errno result) ; error
|
||||||
|
(format (current-error-port) "Error accessing ~a: ~a~%" path (strerror errno))
|
||||||
|
result)
|
||||||
|
#t
|
||||||
|
source)
|
||||||
|
(reverse files)))))
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,8 @@
|
||||||
(define-module (stash paths)
|
(define-module (stash paths)
|
||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
#:export (expand-home
|
#:export (expand-home
|
||||||
canonicalize-path
|
normalize-path
|
||||||
|
relative-path
|
||||||
concat-path
|
concat-path
|
||||||
ensure-config-path))
|
ensure-config-path))
|
||||||
|
|
||||||
|
|
@ -31,8 +32,9 @@
|
||||||
(string-append target-dir "/.config")
|
(string-append target-dir "/.config")
|
||||||
target-dir)))
|
target-dir)))
|
||||||
|
|
||||||
;;; Function to canonicalize a path (resolve . and ..)
|
;;; Function to normalize a path (resolve . and ..)
|
||||||
(define (canonicalize-path path)
|
(define (normalize-path path)
|
||||||
|
"Normalize a path by resolving . and .. components and expanding ~"
|
||||||
(let* ((expanded-path (expand-home path))
|
(let* ((expanded-path (expand-home path))
|
||||||
(absolute-path (if (string-prefix? "/" expanded-path)
|
(absolute-path (if (string-prefix? "/" expanded-path)
|
||||||
expanded-path
|
expanded-path
|
||||||
|
|
@ -50,6 +52,31 @@
|
||||||
(else
|
(else
|
||||||
(set! result (cons component result)))))
|
(set! result (cons component result)))))
|
||||||
components)
|
components)
|
||||||
|
|
||||||
;; Build the final path
|
;; Build the final path
|
||||||
(string-append "/" (string-join (reverse result) "/"))))
|
(string-append "/" (string-join (reverse result) "/"))))
|
||||||
|
|
||||||
|
;;; Function to get relative path from base to target
|
||||||
|
(define (relative-path base target)
|
||||||
|
"Get the relative path from base to target"
|
||||||
|
(let* ((base (normalize-path base))
|
||||||
|
(target (normalize-path target))
|
||||||
|
(base-parts (filter (lambda (x) (not (string=? x "")))
|
||||||
|
(string-split base #\/)))
|
||||||
|
(target-parts (filter (lambda (x) (not (string=? x "")))
|
||||||
|
(string-split target #\/)))
|
||||||
|
(common-prefix-length
|
||||||
|
(let loop ((i 0))
|
||||||
|
(if (and (< i (length base-parts))
|
||||||
|
(< i (length target-parts))
|
||||||
|
(string=? (list-ref base-parts i)
|
||||||
|
(list-ref target-parts i)))
|
||||||
|
(loop (+ i 1))
|
||||||
|
i)))
|
||||||
|
(up-count (- (length base-parts) common-prefix-length))
|
||||||
|
(down-parts (list-tail target-parts common-prefix-length)))
|
||||||
|
(if (and (= up-count 0) (null? down-parts))
|
||||||
|
"."
|
||||||
|
(string-join
|
||||||
|
(append (make-list up-count "..")
|
||||||
|
down-parts)
|
||||||
|
"/"))))
|
||||||
|
|
|
||||||
|
|
@ -2,19 +2,21 @@
|
||||||
#:use-module (srfi srfi-9) ; For record types
|
#:use-module (srfi srfi-9) ; For record types
|
||||||
#:use-module (ice-9 ftw)
|
#:use-module (ice-9 ftw)
|
||||||
#:use-module (ice-9 regex) ; For string-match
|
#:use-module (ice-9 regex) ; For string-match
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1) ; For any and fold
|
||||||
#:use-module (stash package)
|
|
||||||
#:use-module (stash file-ops)
|
#:use-module (stash file-ops)
|
||||||
#:use-module (stash log)
|
#:use-module (stash log)
|
||||||
|
#:use-module (stash paths)
|
||||||
#:export (analyze-tree
|
#:export (analyze-tree
|
||||||
fold-tree
|
fold-tree
|
||||||
plan-operations))
|
plan-operations
|
||||||
|
scan-directory
|
||||||
|
tree-contains?))
|
||||||
|
|
||||||
(use-modules (ice-9 ftw)
|
(use-modules (ice-9 ftw)
|
||||||
(ice-9 regex)
|
(ice-9 regex)
|
||||||
(srfi srfi-1)
|
(srfi srfi-1)
|
||||||
(stash package)
|
(stash file-ops)
|
||||||
(stash file-ops))
|
(stash paths))
|
||||||
|
|
||||||
;; Tree node record type
|
;; Tree node record type
|
||||||
(define-record-type <tree-node>
|
(define-record-type <tree-node>
|
||||||
|
|
@ -24,71 +26,76 @@
|
||||||
(type node-type) ; 'file, 'directory, or 'symlink
|
(type node-type) ; 'file, 'directory, or 'symlink
|
||||||
(children node-children))
|
(children node-children))
|
||||||
|
|
||||||
;; Check if a path should be ignored based on patterns
|
|
||||||
(define (should-ignore? path patterns)
|
|
||||||
(any (lambda (pattern)
|
|
||||||
(string-match pattern path))
|
|
||||||
patterns))
|
|
||||||
|
|
||||||
;; Analyze directory tree and create tree structure
|
;; Analyze directory tree and create tree structure
|
||||||
(define (analyze-tree package)
|
(define* (analyze-tree root-path #:optional (ignore-patterns '()))
|
||||||
(let ((root-path (package-path package))
|
(let analyze ((path root-path))
|
||||||
(ignore-patterns (package-ignore-patterns package)))
|
(cond
|
||||||
(let analyze ((path root-path))
|
((file-is-symlink? path)
|
||||||
(if (should-ignore? path ignore-patterns)
|
(make-tree-node path 'symlink '()))
|
||||||
#f
|
((file-is-directory? path)
|
||||||
(cond
|
(let* ((entries (scandir path))
|
||||||
((file-is-symlink? path)
|
(children (filter-map
|
||||||
(make-tree-node path 'symlink '()))
|
(lambda (entry)
|
||||||
((file-is-directory? path)
|
(if (or (member entry '("." ".."))
|
||||||
(let* ((entries (scandir path))
|
(and (not (null? ignore-patterns))
|
||||||
(children (filter-map
|
(any (lambda (pattern)
|
||||||
(lambda (entry)
|
(string-match pattern entry))
|
||||||
(if (member entry '("." ".."))
|
ignore-patterns)))
|
||||||
#f
|
#f
|
||||||
(analyze (string-append path "/" entry))))
|
(analyze (string-append path "/" entry))))
|
||||||
entries)))
|
entries)))
|
||||||
(make-tree-node path 'directory children)))
|
(make-tree-node path 'directory children)))
|
||||||
(else
|
(else
|
||||||
(make-tree-node path 'file '())))))))
|
(make-tree-node path 'file '())))))
|
||||||
|
|
||||||
;; Determine if a directory tree can be folded
|
;; Fold over a tree structure
|
||||||
(define (can-fold-tree? node target-base)
|
(define (fold-tree proc init tree)
|
||||||
(and (tree-node? node)
|
(let fold-node ((node tree)
|
||||||
(eq? (node-type node) 'directory)
|
(acc init))
|
||||||
(= (length (node-children node)) 1)
|
(let ((new-acc (proc node acc)))
|
||||||
(let ((child (car (node-children node))))
|
(if (eq? (node-type node) 'directory)
|
||||||
(and (eq? (node-type child) 'directory)
|
(let fold-children ((children (node-children node))
|
||||||
(not (file-exists? (string-append target-base "/"
|
(child-acc new-acc))
|
||||||
(basename (node-path node)))))))))
|
(if (null? children)
|
||||||
|
child-acc
|
||||||
|
(fold-children (cdr children)
|
||||||
|
(fold-node (car children) child-acc))))
|
||||||
|
new-acc))))
|
||||||
|
|
||||||
|
;; Scan a directory and create a tree structure
|
||||||
|
(define (scan-directory dir-path)
|
||||||
|
(analyze-tree dir-path))
|
||||||
|
|
||||||
|
;; Check if a tree contains a specific path
|
||||||
|
(define (tree-contains? tree path)
|
||||||
|
(let* ((tree-path (node-path tree))
|
||||||
|
(target-path (if (string-prefix? "/" path)
|
||||||
|
path
|
||||||
|
(string-append (dirname tree-path) "/" path))))
|
||||||
|
(or (string=? tree-path target-path)
|
||||||
|
(let check-children ((children (node-children tree)))
|
||||||
|
(and (not (null? children))
|
||||||
|
(or (string=? (node-path (car children)) target-path)
|
||||||
|
(and (eq? (node-type (car children)) 'directory)
|
||||||
|
(tree-contains? (car children) target-path))
|
||||||
|
(check-children (cdr children))))))))
|
||||||
|
|
||||||
;; Plan stow operations for a tree
|
;; Plan stow operations for a tree
|
||||||
(define (plan-operations tree package)
|
(define (plan-operations tree target-dir)
|
||||||
(let* ((source-base (package-path package))
|
(let ((source-base (node-path tree)))
|
||||||
(target-base (package-target package))
|
(fold-tree
|
||||||
(source-name (package-name package))
|
(lambda (node acc)
|
||||||
(target-path (string-append target-base "/" source-name)))
|
(let* ((relative-path (relative-path source-base (node-path node)))
|
||||||
(format #t "Source base: ~a~%" source-base)
|
(target-path (string-append target-dir "/" relative-path)))
|
||||||
(format #t "Target base: ~a~%" target-base)
|
(cond
|
||||||
(format #t "Source name: ~a~%" source-name)
|
((eq? (node-type node) 'directory)
|
||||||
(format #t "Target path: ~a~%" target-path)
|
(if (not (file-exists? target-path))
|
||||||
|
(cons `(mkdir ,target-path) acc)
|
||||||
;; Create parent directory if it doesn't exist
|
acc))
|
||||||
(let ((target-dir (dirname target-path)))
|
((eq? (node-type node) 'file)
|
||||||
(when (not (file-exists? target-dir))
|
(if (not (file-exists? target-path))
|
||||||
(format #t "Creating parent directory: ~a~%" target-dir)
|
(cons `(symlink ,(node-path node) ,target-path) acc)
|
||||||
(mkdir-p target-dir)))
|
acc))
|
||||||
|
(else acc))))
|
||||||
;; Remove existing directory or file
|
'()
|
||||||
(when (file-exists? target-path)
|
tree)))
|
||||||
(format #t "Removing existing path: ~a~%" target-path)
|
|
||||||
(system (string-append "rm -rf " target-path)))
|
|
||||||
|
|
||||||
;; Move source to target
|
|
||||||
(format #t "Moving ~a to ~a~%" source-base target-path)
|
|
||||||
(rename-file source-base target-path)
|
|
||||||
|
|
||||||
;; Create symlink
|
|
||||||
(format #t "Creating symlink: ~a -> ~a~%" source-base target-path)
|
|
||||||
(symlink target-path source-base)
|
|
||||||
'()))
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,39 @@
|
||||||
|
#!/bin/bash
|
||||||
|
|
||||||
|
# Exit on error
|
||||||
|
set -e
|
||||||
|
|
||||||
|
# Directory setup
|
||||||
|
PROJECT_ROOT="$PWD"
|
||||||
|
MODULE_DIR="$PROJECT_ROOT/modules"
|
||||||
|
TEST_DIR="$PROJECT_ROOT/tests"
|
||||||
|
|
||||||
|
# Add project directories to GUILE_LOAD_PATH
|
||||||
|
export GUILE_LOAD_PATH="$PROJECT_ROOT:$MODULE_DIR:$TEST_DIR:$GUILE_LOAD_PATH"
|
||||||
|
export GUILE_LOAD_COMPILED_PATH="$MODULE_DIR:$TEST_DIR:$GUILE_LOAD_COMPILED_PATH"
|
||||||
|
|
||||||
|
# Disable auto-compilation during tests
|
||||||
|
export GUILE_AUTO_COMPILE=0
|
||||||
|
|
||||||
|
# Compile all Scheme files first
|
||||||
|
echo "Compiling Scheme modules..."
|
||||||
|
find "$MODULE_DIR" -name "*.scm" -type f -exec guild compile {} \;
|
||||||
|
echo "Compiling test files..."
|
||||||
|
find "$TEST_DIR" -name "*.scm" -type f -exec guild compile {} \;
|
||||||
|
|
||||||
|
# Function to run a test file
|
||||||
|
run_test() {
|
||||||
|
local test_file="$1"
|
||||||
|
echo "Running tests in $test_file..."
|
||||||
|
guile --no-auto-compile "$test_file"
|
||||||
|
}
|
||||||
|
|
||||||
|
# Run all test files
|
||||||
|
echo "Running tests..."
|
||||||
|
for test_file in "$TEST_DIR"/*-test.scm; do
|
||||||
|
if [ -f "$test_file" ]; then
|
||||||
|
run_test "$test_file"
|
||||||
|
fi
|
||||||
|
done
|
||||||
|
|
||||||
|
echo "All tests completed successfully!"
|
||||||
|
|
@ -0,0 +1,65 @@
|
||||||
|
# Stash Test Suite
|
||||||
|
|
||||||
|
This directory contains the comprehensive test suite for the Stash project. The tests are written using SRFI-64, Scheme's standard testing framework.
|
||||||
|
|
||||||
|
## Test Structure
|
||||||
|
|
||||||
|
- `run-tests.scm` - Main test runner that executes all test files
|
||||||
|
- `test-helpers.scm` - Common testing utilities and fixtures
|
||||||
|
- Module-specific test files:
|
||||||
|
- `paths-test.scm` - Tests for path handling functionality
|
||||||
|
- `package-test.scm` - Tests for package management
|
||||||
|
- `tree-test.scm` - Tests for directory tree operations
|
||||||
|
- `file-ops-test.scm` - Tests for file system operations
|
||||||
|
- `conflict-test.scm` - Tests for conflict detection and resolution
|
||||||
|
|
||||||
|
## Running Tests
|
||||||
|
|
||||||
|
You can run the entire test suite using the script in the project root:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
./run-tests.sh
|
||||||
|
```
|
||||||
|
|
||||||
|
Or run individual test files directly with Guile:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
GUILE_LOAD_PATH="$PWD:$GUILE_LOAD_PATH" guile tests/paths-test.scm
|
||||||
|
```
|
||||||
|
|
||||||
|
## Writing New Tests
|
||||||
|
|
||||||
|
1. Create a new test file following the naming convention `*-test.scm`
|
||||||
|
2. Use the SRFI-64 test framework
|
||||||
|
3. Import required modules and test helpers:
|
||||||
|
```scheme
|
||||||
|
(use-modules (srfi srfi-64)
|
||||||
|
(stash your-module)
|
||||||
|
(test-helpers))
|
||||||
|
```
|
||||||
|
4. Organize tests into logical groups using `test-group`
|
||||||
|
5. Use the test helper functions for common operations
|
||||||
|
|
||||||
|
Example:
|
||||||
|
```scheme
|
||||||
|
(test-begin "your-module")
|
||||||
|
|
||||||
|
(test-group "feature-name"
|
||||||
|
(test-assert "description"
|
||||||
|
(your-function-call)))
|
||||||
|
|
||||||
|
(test-end "your-module")
|
||||||
|
```
|
||||||
|
|
||||||
|
## Test Helpers
|
||||||
|
|
||||||
|
The `test-helpers.scm` module provides several utilities:
|
||||||
|
|
||||||
|
- `with-temporary-directory`: Creates and manages temporary test directories
|
||||||
|
- `create-test-file`: Creates test files with optional content
|
||||||
|
- `create-test-symlink`: Creates test symlinks
|
||||||
|
- `delete-directory-recursive`: Safely removes test directories
|
||||||
|
|
||||||
|
## Adding New Test Helpers
|
||||||
|
|
||||||
|
If you find yourself repeating test setup code, consider adding new helper functions to `test-helpers.scm`.
|
||||||
|
|
@ -0,0 +1,64 @@
|
||||||
|
(use-modules (srfi srfi-64)
|
||||||
|
(stash conflict)
|
||||||
|
(test-helpers))
|
||||||
|
|
||||||
|
(test-begin "conflict")
|
||||||
|
|
||||||
|
;; Test conflict detection
|
||||||
|
(test-group "conflict-detection"
|
||||||
|
(with-temporary-directory temp-dir
|
||||||
|
;; Setup test scenario
|
||||||
|
(let* ((source-path (string-append temp-dir "/source/config"))
|
||||||
|
(target-path (string-append temp-dir "/target/config")))
|
||||||
|
|
||||||
|
;; Test case 1: No conflict (target doesn't exist)
|
||||||
|
(create-test-file source-path "source content")
|
||||||
|
(test-assert "Should not detect conflict when target doesn't exist"
|
||||||
|
(not (has-conflict? source-path target-path)))
|
||||||
|
|
||||||
|
;; Test case 2: Conflict with existing file
|
||||||
|
(create-test-file target-path "target content")
|
||||||
|
(test-assert "Should detect conflict with existing file"
|
||||||
|
(has-conflict? source-path target-path))
|
||||||
|
|
||||||
|
;; Test case 3: Conflict with directory
|
||||||
|
(delete-file target-path)
|
||||||
|
(mkdir target-path)
|
||||||
|
(test-assert "Should detect conflict with directory"
|
||||||
|
(has-conflict? source-path target-path)))))
|
||||||
|
|
||||||
|
;; Test conflict resolution strategies
|
||||||
|
(test-group "conflict-resolution"
|
||||||
|
(with-temporary-directory temp-dir
|
||||||
|
(let* ((source-path (string-append temp-dir "/source/config"))
|
||||||
|
(target-path (string-append temp-dir "/target/config")))
|
||||||
|
|
||||||
|
;; Setup test files
|
||||||
|
(create-test-file source-path "source content")
|
||||||
|
(create-test-file target-path "target content")
|
||||||
|
|
||||||
|
;; Test backup strategy
|
||||||
|
(test-assert "Backup strategy should succeed"
|
||||||
|
(resolve-conflict source-path target-path 'backup))
|
||||||
|
|
||||||
|
(test-assert "Backup file should exist"
|
||||||
|
(file-exists? (string-append target-path ".bak")))
|
||||||
|
|
||||||
|
;; Test overwrite strategy
|
||||||
|
(create-test-file target-path "target content")
|
||||||
|
(test-assert "Overwrite strategy should succeed"
|
||||||
|
(resolve-conflict source-path target-path 'overwrite))
|
||||||
|
|
||||||
|
(test-equal "Target should contain source content"
|
||||||
|
"source content"
|
||||||
|
(with-input-from-file target-path read-string))
|
||||||
|
|
||||||
|
;; Test skip strategy
|
||||||
|
(test-assert "Skip strategy should succeed"
|
||||||
|
(resolve-conflict source-path target-path 'skip))
|
||||||
|
|
||||||
|
(test-equal "Target should remain unchanged"
|
||||||
|
"source content"
|
||||||
|
(with-input-from-file target-path read-string)))))
|
||||||
|
|
||||||
|
(test-end "conflict")
|
||||||
|
|
@ -0,0 +1,101 @@
|
||||||
|
(use-modules (srfi srfi-64)
|
||||||
|
(stash file-ops)
|
||||||
|
(test-helpers))
|
||||||
|
|
||||||
|
(test-begin "file-ops")
|
||||||
|
|
||||||
|
;; Test basic file operations
|
||||||
|
(test-group "basic-operations"
|
||||||
|
(with-temporary-directory temp-dir
|
||||||
|
;; Test directory creation
|
||||||
|
(let ((test-dir (string-append temp-dir "/new-dir")))
|
||||||
|
(test-assert "Should create directory"
|
||||||
|
(begin
|
||||||
|
(ensure-directory test-dir)
|
||||||
|
(file-exists? test-dir)))
|
||||||
|
|
||||||
|
(test-assert "Should handle existing directory"
|
||||||
|
(begin
|
||||||
|
(ensure-directory test-dir)
|
||||||
|
(file-exists? test-dir))))
|
||||||
|
|
||||||
|
;; Test file existence checks
|
||||||
|
(let ((test-file (string-append temp-dir "/test.txt")))
|
||||||
|
(create-test-file test-file)
|
||||||
|
|
||||||
|
(test-assert "Should detect existing file"
|
||||||
|
(file-exists? test-file))
|
||||||
|
|
||||||
|
(test-assert "Should detect non-existing file"
|
||||||
|
(not (file-exists? (string-append temp-dir "/nonexistent")))))))
|
||||||
|
|
||||||
|
;; Test recursive operations
|
||||||
|
(test-group "recursive-operations"
|
||||||
|
(with-temporary-directory temp-dir
|
||||||
|
;; Create test directory structure
|
||||||
|
(let ((dir1 (string-append temp-dir "/dir1"))
|
||||||
|
(dir2 (string-append temp-dir "/dir2")))
|
||||||
|
|
||||||
|
(create-test-file (string-append dir1 "/file1.txt"))
|
||||||
|
(create-test-file (string-append dir1 "/subdir/file2.txt"))
|
||||||
|
|
||||||
|
;; Test recursive copy
|
||||||
|
(copy-recursive dir1 dir2)
|
||||||
|
|
||||||
|
(test-assert "Should copy top-level file"
|
||||||
|
(file-exists? (string-append dir2 "/file1.txt")))
|
||||||
|
|
||||||
|
(test-assert "Should copy nested file"
|
||||||
|
(file-exists? (string-append dir2 "/subdir/file2.txt")))
|
||||||
|
|
||||||
|
;; Test recursive delete
|
||||||
|
(delete-recursive dir2)
|
||||||
|
|
||||||
|
(test-assert "Should delete entire directory"
|
||||||
|
(not (file-exists? dir2))))))
|
||||||
|
|
||||||
|
;; Test file permission operations
|
||||||
|
(test-group "permission-operations"
|
||||||
|
(with-temporary-directory temp-dir
|
||||||
|
(let ((test-file (string-append temp-dir "/permissions.txt")))
|
||||||
|
;; Create test file
|
||||||
|
(create-test-file test-file)
|
||||||
|
|
||||||
|
;; Test permission changes
|
||||||
|
(make-file-executable test-file)
|
||||||
|
(test-assert "Should make file executable"
|
||||||
|
(file-is-executable? test-file))
|
||||||
|
|
||||||
|
(make-file-readable test-file)
|
||||||
|
(test-assert "Should make file readable"
|
||||||
|
(file-is-readable? test-file)))))
|
||||||
|
|
||||||
|
;; Test symlink operations
|
||||||
|
(test-group "symlink-operations"
|
||||||
|
(with-temporary-directory temp-dir
|
||||||
|
(let ((source-file (string-append temp-dir "/source.txt"))
|
||||||
|
(link-file (string-append temp-dir "/link.txt")))
|
||||||
|
|
||||||
|
;; Create source file
|
||||||
|
(create-test-file source-file "test content")
|
||||||
|
|
||||||
|
;; Test symlink creation
|
||||||
|
(create-symlink source-file link-file)
|
||||||
|
|
||||||
|
(test-assert "Should create symlink"
|
||||||
|
(file-is-symlink? link-file))
|
||||||
|
|
||||||
|
(test-equal "Symlink should point to source"
|
||||||
|
(canonicalize-path source-file)
|
||||||
|
(resolve-symlink link-file))
|
||||||
|
|
||||||
|
;; Test symlink update
|
||||||
|
(let ((new-source (string-append temp-dir "/new-source.txt")))
|
||||||
|
(create-test-file new-source "new content")
|
||||||
|
(update-symlink new-source link-file)
|
||||||
|
|
||||||
|
(test-equal "Updated symlink should point to new source"
|
||||||
|
(canonicalize-path new-source)
|
||||||
|
(resolve-symlink link-file))))))
|
||||||
|
|
||||||
|
(test-end "file-ops")
|
||||||
|
|
@ -0,0 +1,73 @@
|
||||||
|
(use-modules (srfi srfi-64)
|
||||||
|
(stash package)
|
||||||
|
(test-helpers))
|
||||||
|
|
||||||
|
(test-begin "package")
|
||||||
|
|
||||||
|
;; Test package record creation and manipulation
|
||||||
|
(test-group "package-record"
|
||||||
|
(let ((pkg (make-package "test-pkg" "/source/path" "/target/path" '("*.bak" ".git/"))))
|
||||||
|
(test-equal "Package name"
|
||||||
|
"test-pkg"
|
||||||
|
(package-name pkg))
|
||||||
|
|
||||||
|
(test-equal "Source path"
|
||||||
|
"/source/path"
|
||||||
|
(package-source pkg))
|
||||||
|
|
||||||
|
(test-equal "Target path"
|
||||||
|
"/target/path"
|
||||||
|
(package-target pkg))
|
||||||
|
|
||||||
|
(test-equal "Ignore patterns"
|
||||||
|
'("*.bak" ".git/")
|
||||||
|
(package-ignores pkg))))
|
||||||
|
|
||||||
|
;; Test ignore pattern handling
|
||||||
|
(test-group "ignore-patterns"
|
||||||
|
(with-temporary-directory temp-dir
|
||||||
|
;; Create test files
|
||||||
|
(create-test-file (string-append temp-dir "/normal.txt"))
|
||||||
|
(create-test-file (string-append temp-dir "/ignore.bak"))
|
||||||
|
(create-test-file (string-append temp-dir "/.git/config"))
|
||||||
|
|
||||||
|
(let ((pkg (make-package "test-pkg" temp-dir "/target" '("*.bak" ".git/"))))
|
||||||
|
(test-equal "Should ignore backup files"
|
||||||
|
#f
|
||||||
|
(should-include-file? pkg (string-append temp-dir "/ignore.bak")))
|
||||||
|
|
||||||
|
(test-equal "Should ignore git directory"
|
||||||
|
#f
|
||||||
|
(should-include-file? pkg (string-append temp-dir "/.git/config")))
|
||||||
|
|
||||||
|
(test-equal "Should include normal files"
|
||||||
|
#t
|
||||||
|
(should-include-file? pkg (string-append temp-dir "/normal.txt"))))))
|
||||||
|
|
||||||
|
;; Test package file operations
|
||||||
|
(test-group "package-operations"
|
||||||
|
(with-temporary-directory temp-dir
|
||||||
|
(let* ((source-dir (string-append temp-dir "/source"))
|
||||||
|
(target-dir (string-append temp-dir "/target"))
|
||||||
|
(pkg (make-package "test-pkg" source-dir target-dir '())))
|
||||||
|
|
||||||
|
;; Create test directory structure
|
||||||
|
(create-test-file (string-append source-dir "/config.txt"))
|
||||||
|
(create-test-file (string-append source-dir "/subdir/nested.txt"))
|
||||||
|
|
||||||
|
;; Test package scanning
|
||||||
|
(test-assert "Package directory exists"
|
||||||
|
(package-exists? pkg))
|
||||||
|
|
||||||
|
(let ((files (scan-package-files pkg)))
|
||||||
|
(test-equal "Should find all package files"
|
||||||
|
2
|
||||||
|
(length files))
|
||||||
|
|
||||||
|
(test-assert "Should find root file"
|
||||||
|
(member "config.txt" (map basename files)))
|
||||||
|
|
||||||
|
(test-assert "Should find nested file"
|
||||||
|
(member "nested.txt" (map basename files)))))))
|
||||||
|
|
||||||
|
(test-end "package")
|
||||||
|
|
@ -0,0 +1,42 @@
|
||||||
|
(use-modules (srfi srfi-64)
|
||||||
|
(stash paths))
|
||||||
|
|
||||||
|
(test-begin "paths")
|
||||||
|
|
||||||
|
;; Test normalize-path
|
||||||
|
(test-group "normalize-path"
|
||||||
|
(test-equal "Simple path normalization"
|
||||||
|
"/home/user/file"
|
||||||
|
(normalize-path "/home/user/file"))
|
||||||
|
|
||||||
|
(test-equal "Remove double slashes"
|
||||||
|
"/home/user/file"
|
||||||
|
(normalize-path "/home//user///file"))
|
||||||
|
|
||||||
|
(test-equal "Handle dot notation"
|
||||||
|
"/home/user/file"
|
||||||
|
(normalize-path "/home/user/./file"))
|
||||||
|
|
||||||
|
(test-equal "Handle dot-dot notation"
|
||||||
|
"/home/file"
|
||||||
|
(normalize-path "/home/user/../file"))
|
||||||
|
|
||||||
|
(test-equal "Handle home directory expansion"
|
||||||
|
(string-append (getenv "HOME") "/file")
|
||||||
|
(normalize-path "~/file")))
|
||||||
|
|
||||||
|
;; Test relative path handling
|
||||||
|
(test-group "relative-path"
|
||||||
|
(test-equal "Simple relative path"
|
||||||
|
"file"
|
||||||
|
(relative-path "/home/user" "/home/user/file"))
|
||||||
|
|
||||||
|
(test-equal "Nested relative path"
|
||||||
|
"dir/file"
|
||||||
|
(relative-path "/home/user" "/home/user/dir/file"))
|
||||||
|
|
||||||
|
(test-equal "Parent directory"
|
||||||
|
"../file"
|
||||||
|
(relative-path "/home/user/dir" "/home/user/file")))
|
||||||
|
|
||||||
|
(test-end "paths")
|
||||||
|
|
@ -0,0 +1,28 @@
|
||||||
|
#!/usr/bin/env guile
|
||||||
|
!#
|
||||||
|
|
||||||
|
(use-modules (srfi srfi-64) ; testing framework
|
||||||
|
(srfi srfi-1) ; list operations
|
||||||
|
(ice-9 ftw) ; file tree walk
|
||||||
|
(ice-9 match)) ; pattern matching
|
||||||
|
|
||||||
|
;; Configure test engine
|
||||||
|
(test-runner-current (test-runner-create))
|
||||||
|
|
||||||
|
;; Helper function to run all test files
|
||||||
|
(define (run-test-file filename)
|
||||||
|
(format #t "\nRunning tests from ~a:\n" filename)
|
||||||
|
(primitive-load filename))
|
||||||
|
|
||||||
|
;; Find and run all test files
|
||||||
|
(define (run-all-tests)
|
||||||
|
(let ((test-files (filter (lambda (file)
|
||||||
|
(string-suffix? "-test.scm" file))
|
||||||
|
(scandir "."))))
|
||||||
|
(for-each run-test-file test-files)))
|
||||||
|
|
||||||
|
;; Run all tests
|
||||||
|
(run-all-tests)
|
||||||
|
|
||||||
|
;; Exit with appropriate status code
|
||||||
|
(exit (zero? (test-runner-fail-count (test-runner-current))))
|
||||||
|
|
@ -0,0 +1,82 @@
|
||||||
|
;; test-helpers.scm --- Helper functions for Stash tests
|
||||||
|
|
||||||
|
(define-module (test-helpers)
|
||||||
|
#:use-module (ice-9 ftw)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (ice-9 rdelim)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:export (with-temporary-directory
|
||||||
|
create-test-file
|
||||||
|
create-test-symlink
|
||||||
|
delete-directory-recursive
|
||||||
|
read-string))
|
||||||
|
|
||||||
|
;; Create a temporary directory and run thunk with it
|
||||||
|
(define-syntax-rule (with-temporary-directory dir-name body ...)
|
||||||
|
(let* ((tmp-dir (string-append (or (getenv "TMPDIR") "/tmp")
|
||||||
|
"/stash-test-"
|
||||||
|
(number->string (current-time))))
|
||||||
|
(dir-name tmp-dir))
|
||||||
|
(mkdir tmp-dir)
|
||||||
|
(dynamic-wind
|
||||||
|
(lambda () #t)
|
||||||
|
(lambda () body ...)
|
||||||
|
(lambda () (delete-directory-recursive tmp-dir)))))
|
||||||
|
|
||||||
|
;; Create a test file with optional content
|
||||||
|
(define* (create-test-file path #:optional (content "test content\n"))
|
||||||
|
(let ((dir (dirname path)))
|
||||||
|
(when (not (file-exists? dir))
|
||||||
|
(mkdir-p dir))
|
||||||
|
(with-output-to-file path
|
||||||
|
(lambda ()
|
||||||
|
(display content)))))
|
||||||
|
|
||||||
|
;; Create a test symlink
|
||||||
|
(define (create-test-symlink target link-name)
|
||||||
|
(let ((dir (dirname link-name)))
|
||||||
|
(when (not (file-exists? dir))
|
||||||
|
(mkdir-p dir))
|
||||||
|
(symlink target link-name)))
|
||||||
|
|
||||||
|
;; Helper function to create directories recursively
|
||||||
|
(define (mkdir-p dir)
|
||||||
|
(let loop ((components (filter (lambda (x) (not (string-null? x)))
|
||||||
|
(string-split dir #\/)))
|
||||||
|
(path (if (string-prefix? "/" dir) "/" "")))
|
||||||
|
(unless (null? components)
|
||||||
|
(let ((new-path (if (string=? path "/")
|
||||||
|
(string-append path (car components))
|
||||||
|
(if (string-null? path)
|
||||||
|
(car components)
|
||||||
|
(string-append path "/" (car components))))))
|
||||||
|
(when (not (file-exists? new-path))
|
||||||
|
(mkdir new-path))
|
||||||
|
(loop (cdr components) new-path)))))
|
||||||
|
|
||||||
|
;; Recursively delete a directory
|
||||||
|
(define (delete-directory-recursive dir)
|
||||||
|
(when (file-exists? dir)
|
||||||
|
(file-system-fold
|
||||||
|
(const #t) ; enter?
|
||||||
|
(lambda (path stat result) ; leaf
|
||||||
|
(delete-file path))
|
||||||
|
(const #t) ; down
|
||||||
|
(lambda (path stat result) ; up
|
||||||
|
(rmdir path))
|
||||||
|
(const #t) ; skip
|
||||||
|
(lambda (path stat errno result) ; error
|
||||||
|
(format (current-error-port)
|
||||||
|
"Warning: ~a: ~a~%"
|
||||||
|
path
|
||||||
|
(strerror errno)))
|
||||||
|
#t
|
||||||
|
dir)))
|
||||||
|
|
||||||
|
;; Read entire contents of current input port as a string
|
||||||
|
(define (read-string)
|
||||||
|
(let loop ((chars '()))
|
||||||
|
(let ((char (read-char)))
|
||||||
|
(if (eof-object? char)
|
||||||
|
(list->string (reverse chars))
|
||||||
|
(loop (cons char chars))))))
|
||||||
|
|
@ -0,0 +1,55 @@
|
||||||
|
(use-modules (srfi srfi-64)
|
||||||
|
(srfi srfi-1) ; For any
|
||||||
|
(stash tree)
|
||||||
|
(stash paths)
|
||||||
|
(test-helpers))
|
||||||
|
|
||||||
|
(test-begin "tree")
|
||||||
|
|
||||||
|
;; Test directory tree operations
|
||||||
|
(test-group "directory-tree"
|
||||||
|
(with-temporary-directory temp-dir
|
||||||
|
;; Create test directory structure
|
||||||
|
(create-test-file (string-append temp-dir "/file1.txt"))
|
||||||
|
(create-test-file (string-append temp-dir "/dir1/file2.txt"))
|
||||||
|
(create-test-file (string-append temp-dir "/dir1/subdir/file3.txt"))
|
||||||
|
|
||||||
|
;; Test directory scanning
|
||||||
|
(let ((tree (scan-directory temp-dir)))
|
||||||
|
(test-assert "Tree should contain root file"
|
||||||
|
(tree-contains? tree (string-append temp-dir "/file1.txt")))
|
||||||
|
|
||||||
|
(test-assert "Tree should contain nested file"
|
||||||
|
(tree-contains? tree (string-append temp-dir "/dir1/file2.txt")))
|
||||||
|
|
||||||
|
(test-assert "Tree should contain deeply nested file"
|
||||||
|
(tree-contains? tree (string-append temp-dir "/dir1/subdir/file3.txt"))))))
|
||||||
|
|
||||||
|
;; Test symlink planning
|
||||||
|
(test-group "symlink-planning"
|
||||||
|
(with-temporary-directory temp-dir
|
||||||
|
(let* ((source-dir (string-append temp-dir "/source"))
|
||||||
|
(target-dir (string-append temp-dir "/target")))
|
||||||
|
|
||||||
|
;; Create source files
|
||||||
|
(create-test-file (string-append source-dir "/config.txt"))
|
||||||
|
(create-test-file (string-append source-dir "/dir/nested.txt"))
|
||||||
|
|
||||||
|
;; Test operation planning
|
||||||
|
(let* ((tree (scan-directory source-dir))
|
||||||
|
(ops (plan-operations tree target-dir)))
|
||||||
|
(test-assert "Should plan to create target directory"
|
||||||
|
(any (lambda (op)
|
||||||
|
(and (eq? (car op) 'mkdir)
|
||||||
|
(string=? (cadr op)
|
||||||
|
(string-append target-dir "/dir"))))
|
||||||
|
ops))
|
||||||
|
|
||||||
|
(test-assert "Should plan to create symlinks"
|
||||||
|
(any (lambda (op)
|
||||||
|
(and (eq? (car op) 'symlink)
|
||||||
|
(string=? (caddr op)
|
||||||
|
(string-append target-dir "/config.txt"))))
|
||||||
|
ops))))))
|
||||||
|
|
||||||
|
(test-end "tree")
|
||||||
Loading…
Reference in New Issue