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:
GLENN THOMPSON
parent
08f06c6b47
commit
478ba3ae92
|
|
@ -30,7 +30,7 @@
|
|||
1. Channel Configuration
|
||||
- Location: `.guix-channel/`
|
||||
- Status: Configured for distribution
|
||||
- URL: <https://codeberg.org/glenneth/stash>~~~~
|
||||
- URL: <https://codeberg.org/glenneth/stash>
|
||||
- Branch: main
|
||||
|
||||
2. Package Definition
|
||||
|
|
@ -76,50 +76,43 @@
|
|||
- Updated package definition for channel distribution
|
||||
- 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
|
||||
|
||||
1. Testing
|
||||
- Implement comprehensive test suite
|
||||
- Add more test cases for recursive mode
|
||||
|
||||
2. Documentation
|
||||
1. Documentation
|
||||
- Add API documentation for modules
|
||||
- Include more advanced usage examples
|
||||
|
||||
3. Features
|
||||
2. Features
|
||||
- Enhance conflict resolution
|
||||
- Add backup functionality
|
||||
- Improve error reporting
|
||||
|
||||
### Known Issues
|
||||
|
||||
1. Warnings
|
||||
- Intermittent warning about canonicalize-path override
|
||||
- Auto-compilation messages (resolved with GUILE_AUTO_COMPILE=0)
|
||||
No major issues currently. All previous warnings have been resolved:
|
||||
- Fixed warning about canonicalize-path override by renaming to normalize-path
|
||||
- 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
|
||||
|
||||
```sh
|
||||
stash/
|
||||
├── .guix-channel/
|
||||
│ └── stash/
|
||||
│ └── packages/
|
||||
│ └── stash.scm
|
||||
├── modules/
|
||||
│ └── stash/
|
||||
│ ├── colors.scm
|
||||
│ ├── conflict.scm
|
||||
│ ├── file-ops.scm
|
||||
│ ├── 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
|
||||
```
|
||||
1. Root Directory
|
||||
- stash.scm: Main executable
|
||||
- run-tests.sh: Test runner script
|
||||
- .dev-notes.md: Development notes and tracking
|
||||
- README.md: Project overview
|
||||
- USER_GUIDE.md: Detailed user documentation
|
||||
|
||||
2. Modules
|
||||
- modules/stash/: Core functionality modules
|
||||
- tests/: Test suite and helpers
|
||||
- .guix-channel/: Guix distribution configuration
|
||||
|
|
|
|||
108
DEVLOG.md
108
DEVLOG.md
|
|
@ -22,41 +22,48 @@ The project is organized into several modules:
|
|||
|
||||
## 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
|
||||
|
||||
- Enhanced `canonicalize-path` function to handle:
|
||||
- Renamed `canonicalize-path` to `normalize-path` for clarity
|
||||
- Enhanced path normalization to handle:
|
||||
- Dot (.) and dot-dot (..) notation
|
||||
- Home directory expansion (~)
|
||||
- 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:
|
||||
- Dot syntax (stash .)
|
||||
- Explicit source/target paths
|
||||
- Fixed symlink creation to maintain correct directory structure
|
||||
- Added support for creating parent directories as needed
|
||||
- Implemented efficient tree traversal with `fold-tree`
|
||||
- Added proper directory scanning with ignore patterns
|
||||
- Improved symlink planning with cycle detection
|
||||
- Enhanced tree comparison functionality
|
||||
- Added support for recursive operations
|
||||
- Fixed directory structure preservation
|
||||
|
||||
### Package Management
|
||||
### Module Organization
|
||||
|
||||
- Implemented package record type for managing:
|
||||
- Package name
|
||||
- Source path
|
||||
- Target path
|
||||
- Ignore patterns
|
||||
- Added support for reading ignore patterns from:
|
||||
- .stash-local-ignore
|
||||
- .stash-global-ignore
|
||||
- Resolved import conflicts between modules
|
||||
- Fixed warnings about duplicate bindings
|
||||
- Improved module interface consistency
|
||||
- Enhanced error handling and reporting
|
||||
- Added proper documentation strings
|
||||
|
||||
### Testing
|
||||
### Distribution
|
||||
|
||||
- Added comprehensive test suite
|
||||
- Implemented test cases for:
|
||||
- Dot syntax stashing
|
||||
- Explicit path stashing
|
||||
- Path resolution
|
||||
- Symlink creation
|
||||
- Configured Guix channel for distribution
|
||||
- Updated package definition
|
||||
- Added proper version tracking
|
||||
- Improved installation documentation
|
||||
|
||||
## Current Operation
|
||||
|
||||
|
|
@ -92,37 +99,36 @@ Stash now supports three main modes of operation:
|
|||
- Interactively prompts for target directory
|
||||
- Ideal for first-time users and exploratory stashing
|
||||
|
||||
### Symlink Creation Process
|
||||
### Tree Traversal Process
|
||||
|
||||
1. Determines source and target paths
|
||||
2. Creates parent directories if needed
|
||||
3. Removes existing symlink/directory if present
|
||||
4. Creates new symlink pointing to correct location
|
||||
1. Scans source directory recursively
|
||||
2. Builds tree representation
|
||||
3. Applies ignore patterns
|
||||
4. Plans symlink operations
|
||||
5. Validates tree structure
|
||||
6. Creates necessary symlinks
|
||||
|
||||
### Path Resolution
|
||||
### Error Handling
|
||||
|
||||
- Handles both absolute and relative paths
|
||||
- Expands home directory references
|
||||
- Resolves dot and dot-dot notation
|
||||
- Maintains correct directory structure
|
||||
- Detects circular symlinks
|
||||
- Validates path existence
|
||||
- Checks permissions
|
||||
- Handles conflicts gracefully
|
||||
- Provides detailed error messages
|
||||
|
||||
## Known Issues
|
||||
## Next Steps
|
||||
|
||||
- Warning about overriding core binding `canonicalize-path`
|
||||
- This is expected behavior and doesn't affect functionality
|
||||
- Could be addressed in future by renaming the function
|
||||
1. API Documentation
|
||||
- Document module interfaces
|
||||
- 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
|
||||
2. Add comprehensive documentation
|
||||
3. Optimize path handling
|
||||
4. Address module import warnings
|
||||
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
|
||||
3. Performance Optimization
|
||||
- Profile tree operations
|
||||
- Optimize path handling
|
||||
- Improve memory usage
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
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
|
||||
# Install from the local package definition
|
||||
guix package --install-from-file=minimal-package.scm
|
||||
guix pull
|
||||
guix install stash
|
||||
```
|
||||
|
||||
# Configure your shell environment:
|
||||
3. Configure your shell environment:
|
||||
|
||||
```sh
|
||||
# For Fish shell (add to ~/.config/fish/config.fish):
|
||||
set -gx GUIX_PROFILE $HOME/.guix-profile
|
||||
set -gx PATH $GUIX_PROFILE/bin $PATH
|
||||
|
||||
# For Bash (add to ~/.bashrc):
|
||||
export GUIX_PROFILE="$HOME/.guix-profile"
|
||||
. "$GUIX_PROFILE/etc/profile"
|
||||
export GUIX_PROFILE=$HOME/.guix-profile
|
||||
export PATH=$GUIX_PROFILE/bin:$PATH
|
||||
|
||||
# For Zsh (add to ~/.zshrc):
|
||||
export GUIX_PROFILE="$HOME/.guix-profile"
|
||||
. "$GUIX_PROFILE/etc/profile"
|
||||
export GUIX_PROFILE=$HOME/.guix-profile
|
||||
export PATH=$GUIX_PROFILE/bin:$PATH
|
||||
```
|
||||
|
||||
### Method 2: Manual Installation
|
||||
|
|
@ -170,21 +182,27 @@ Default ignore patterns:
|
|||
|
||||
```sh
|
||||
stash/
|
||||
├── stash.scm # Main entry point
|
||||
├── .guix-channel/ # Guix channel configuration
|
||||
│ └── stash/
|
||||
│ └── packages/
|
||||
│ └── stash.scm
|
||||
├── modules/
|
||||
│ └── stash/
|
||||
│ ├── paths.scm # Path handling
|
||||
│ ├── tree.scm # Tree operations
|
||||
│ ├── package.scm # Package management
|
||||
│ ├── file-ops.scm # File operations
|
||||
│ ├── log.scm # Logging
|
||||
│ ├── conflict.scm # Conflict resolution
|
||||
│ ├── colors.scm # Terminal colors
|
||||
│ └── help.scm # Help messages
|
||||
├── README.md # Project overview
|
||||
├── USER-GUIDE.md # Comprehensive user documentation
|
||||
├── DEVLOG.md # Development log
|
||||
└── LICENSE # GNU GPL v3
|
||||
│ ├── colors.scm # Terminal colors
|
||||
│ ├── conflict.scm # Conflict resolution
|
||||
│ ├── file-ops.scm # File operations
|
||||
│ ├── help.scm # Help messages
|
||||
│ ├── log.scm # Logging utilities
|
||||
│ ├── package.scm # Package information
|
||||
│ ├── paths.scm # Path manipulation
|
||||
│ └── tree.scm # Directory tree handling
|
||||
├── tests/ # Test suite
|
||||
│ ├── run-tests.sh
|
||||
│ ├── test-helpers.scm
|
||||
│ └── *-test.scm # Individual test files
|
||||
├── README.md # Project overview
|
||||
├── USER_GUIDE.md # Comprehensive documentation
|
||||
└── stash.scm # Main executable
|
||||
```
|
||||
|
||||
## Dependencies
|
||||
|
|
|
|||
|
|
@ -208,28 +208,39 @@ stash --source ~/Videos --target /media/external/videos --recursive
|
|||
|
||||
### 1. Path Handling
|
||||
|
||||
- Supports home directory expansion (~)
|
||||
- Handles both absolute and relative paths
|
||||
- Maintains directory structure in target location
|
||||
Stash provides robust path handling capabilities:
|
||||
|
||||
### 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
|
||||
- Handles existing symlinks gracefully
|
||||
- Preserves original file permissions
|
||||
The path normalization ensures that:
|
||||
- Redundant path separators are removed
|
||||
- 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
|
||||
- Add patterns similar to `.gitignore`
|
||||
Stash includes sophisticated directory tree handling:
|
||||
|
||||
```sh
|
||||
*.tmp
|
||||
.DS_Store
|
||||
node_modules/
|
||||
```
|
||||
- Recursive directory scanning
|
||||
- Efficient tree traversal
|
||||
- Intelligent ignore patterns (e.g., `.git/`, `*.bak`)
|
||||
- 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
|
||||
- Interactive prompts for resolution
|
||||
|
|
|
|||
|
|
@ -1,60 +1,57 @@
|
|||
;; 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)
|
||||
#: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
|
||||
(use-modules (ice-9 rdelim)
|
||||
(stash colors)) ;; Import the colors module
|
||||
(use-modules (ice-9 rdelim)) ;; Import read-line function for reading user input
|
||||
|
||||
(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
|
||||
(define (prompt-user-for-action)
|
||||
"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)))
|
||||
(cond
|
||||
((string-ci=? response "o") 'overwrite)
|
||||
((string-ci=? response "s") 'skip)
|
||||
((string-ci=? response "c") 'cancel)
|
||||
(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)))))
|
||||
|
||||
;;; Helper function to handle conflicts
|
||||
|
|
@ -65,12 +62,12 @@
|
|||
((eq? choice 'overwrite)
|
||||
(delete-directory 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)))
|
||||
((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)))
|
||||
((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.")
|
||||
(exit 0)))))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,22 @@
|
|||
#:use-module (stash log) ;; Import log-action, current-timestamp
|
||||
#:use-module (stash paths) ;; Import expand-home, concat-path, ensure-config-path
|
||||
#: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
|
||||
(define (shell-quote-argument arg)
|
||||
|
|
@ -54,14 +69,14 @@
|
|||
;;; Helper function to create a symlink
|
||||
(define (create-symlink source target)
|
||||
"Create a symlink from source to target."
|
||||
(when (file-exists? source)
|
||||
(delete-file source))
|
||||
(let ((source-dir (dirname source)))
|
||||
(when (not (file-exists? source-dir))
|
||||
(mkdir-p source-dir)))
|
||||
(format #t "Creating symlink: ~a -> ~a~%" source target)
|
||||
(symlink target source)
|
||||
(log-action (format #f "Created symlink ~a -> ~a" source target)))
|
||||
(when (file-exists? target)
|
||||
(delete-file target))
|
||||
(let ((target-dir (dirname target)))
|
||||
(when (not (file-exists? target-dir))
|
||||
(mkdir-p target-dir)))
|
||||
(format #t "Creating symlink: ~a -> ~a~%" target source)
|
||||
(symlink source target)
|
||||
(log-action (format #f "Created symlink ~a -> ~a" target source)))
|
||||
|
||||
;;; Helper function to check if a path is a symlink
|
||||
(define (file-is-symlink? path)
|
||||
|
|
@ -94,9 +109,65 @@
|
|||
(else (display (format #f "Unknown operation: ~a\n" op)))))
|
||||
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 mkdir-p
|
||||
execute-operations
|
||||
move-source-to-target
|
||||
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)))
|
||||
(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
|
||||
(define (mkdir-p dir)
|
||||
(let loop ((components (string-split dir #\/))
|
||||
(path ""))
|
||||
(let loop ((components (filter (lambda (x) (not (string-null? x)))
|
||||
(string-split dir #\/)))
|
||||
(path (if (string-prefix? "/" dir) "/" "")))
|
||||
(when (not (null? components))
|
||||
(let ((new-path (if (string-null? path)
|
||||
(car components)
|
||||
(string-append path "/" (car components)))))
|
||||
(when (and (not (string-null? new-path))
|
||||
(let ((new-path (if (string=? path "/")
|
||||
(string-append path (car components))
|
||||
(if (string-null? path)
|
||||
(car components)
|
||||
(string-append path "/" (car components))))))
|
||||
(when (and (not (string=? new-path "/"))
|
||||
(not (file-exists? new-path)))
|
||||
(mkdir new-path #o755))
|
||||
(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
|
||||
package?
|
||||
package-name
|
||||
package-path
|
||||
package-source
|
||||
package-target
|
||||
package-ignore-patterns
|
||||
read-ignore-patterns))
|
||||
package-ignores
|
||||
read-ignore-patterns
|
||||
should-include-file?
|
||||
package-exists?
|
||||
scan-package-files))
|
||||
|
||||
;; Package record type
|
||||
(define-record-type <package>
|
||||
(make-package name path target ignore-patterns)
|
||||
(make-package name source target ignores)
|
||||
package?
|
||||
(name package-name)
|
||||
(path package-path)
|
||||
(source package-source)
|
||||
(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
|
||||
(define (read-ignore-patterns package-path)
|
||||
|
|
@ -44,6 +68,50 @@
|
|||
|
||||
;; Check if a path should be ignored based on patterns
|
||||
(define (should-ignore? path patterns)
|
||||
(format #t "Checking path: ~a against patterns: ~a~%" path patterns)
|
||||
(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))
|
||||
|
||||
;; 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)
|
||||
#:use-module (ice-9 regex)
|
||||
#:export (expand-home
|
||||
canonicalize-path
|
||||
normalize-path
|
||||
relative-path
|
||||
concat-path
|
||||
ensure-config-path))
|
||||
|
||||
|
|
@ -31,8 +32,9 @@
|
|||
(string-append target-dir "/.config")
|
||||
target-dir)))
|
||||
|
||||
;;; Function to canonicalize a path (resolve . and ..)
|
||||
(define (canonicalize-path path)
|
||||
;;; Function to normalize a path (resolve . and ..)
|
||||
(define (normalize-path path)
|
||||
"Normalize a path by resolving . and .. components and expanding ~"
|
||||
(let* ((expanded-path (expand-home path))
|
||||
(absolute-path (if (string-prefix? "/" expanded-path)
|
||||
expanded-path
|
||||
|
|
@ -50,6 +52,31 @@
|
|||
(else
|
||||
(set! result (cons component result)))))
|
||||
components)
|
||||
|
||||
;; Build the final path
|
||||
(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 (ice-9 ftw)
|
||||
#:use-module (ice-9 regex) ; For string-match
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (stash package)
|
||||
#:use-module (srfi srfi-1) ; For any and fold
|
||||
#:use-module (stash file-ops)
|
||||
#:use-module (stash log)
|
||||
#:use-module (stash paths)
|
||||
#:export (analyze-tree
|
||||
fold-tree
|
||||
plan-operations))
|
||||
plan-operations
|
||||
scan-directory
|
||||
tree-contains?))
|
||||
|
||||
(use-modules (ice-9 ftw)
|
||||
(ice-9 regex)
|
||||
(srfi srfi-1)
|
||||
(stash package)
|
||||
(stash file-ops))
|
||||
(stash file-ops)
|
||||
(stash paths))
|
||||
|
||||
;; Tree node record type
|
||||
(define-record-type <tree-node>
|
||||
|
|
@ -24,71 +26,76 @@
|
|||
(type node-type) ; 'file, 'directory, or 'symlink
|
||||
(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
|
||||
(define (analyze-tree package)
|
||||
(let ((root-path (package-path package))
|
||||
(ignore-patterns (package-ignore-patterns package)))
|
||||
(let analyze ((path root-path))
|
||||
(if (should-ignore? path ignore-patterns)
|
||||
#f
|
||||
(cond
|
||||
((file-is-symlink? path)
|
||||
(make-tree-node path 'symlink '()))
|
||||
((file-is-directory? path)
|
||||
(let* ((entries (scandir path))
|
||||
(children (filter-map
|
||||
(lambda (entry)
|
||||
(if (member entry '("." ".."))
|
||||
#f
|
||||
(analyze (string-append path "/" entry))))
|
||||
entries)))
|
||||
(make-tree-node path 'directory children)))
|
||||
(else
|
||||
(make-tree-node path 'file '())))))))
|
||||
(define* (analyze-tree root-path #:optional (ignore-patterns '()))
|
||||
(let analyze ((path root-path))
|
||||
(cond
|
||||
((file-is-symlink? path)
|
||||
(make-tree-node path 'symlink '()))
|
||||
((file-is-directory? path)
|
||||
(let* ((entries (scandir path))
|
||||
(children (filter-map
|
||||
(lambda (entry)
|
||||
(if (or (member entry '("." ".."))
|
||||
(and (not (null? ignore-patterns))
|
||||
(any (lambda (pattern)
|
||||
(string-match pattern entry))
|
||||
ignore-patterns)))
|
||||
#f
|
||||
(analyze (string-append path "/" entry))))
|
||||
entries)))
|
||||
(make-tree-node path 'directory children)))
|
||||
(else
|
||||
(make-tree-node path 'file '())))))
|
||||
|
||||
;; Determine if a directory tree can be folded
|
||||
(define (can-fold-tree? node target-base)
|
||||
(and (tree-node? node)
|
||||
(eq? (node-type node) 'directory)
|
||||
(= (length (node-children node)) 1)
|
||||
(let ((child (car (node-children node))))
|
||||
(and (eq? (node-type child) 'directory)
|
||||
(not (file-exists? (string-append target-base "/"
|
||||
(basename (node-path node)))))))))
|
||||
;; Fold over a tree structure
|
||||
(define (fold-tree proc init tree)
|
||||
(let fold-node ((node tree)
|
||||
(acc init))
|
||||
(let ((new-acc (proc node acc)))
|
||||
(if (eq? (node-type node) 'directory)
|
||||
(let fold-children ((children (node-children node))
|
||||
(child-acc new-acc))
|
||||
(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
|
||||
(define (plan-operations tree package)
|
||||
(let* ((source-base (package-path package))
|
||||
(target-base (package-target package))
|
||||
(source-name (package-name package))
|
||||
(target-path (string-append target-base "/" source-name)))
|
||||
(format #t "Source base: ~a~%" source-base)
|
||||
(format #t "Target base: ~a~%" target-base)
|
||||
(format #t "Source name: ~a~%" source-name)
|
||||
(format #t "Target path: ~a~%" target-path)
|
||||
|
||||
;; Create parent directory if it doesn't exist
|
||||
(let ((target-dir (dirname target-path)))
|
||||
(when (not (file-exists? target-dir))
|
||||
(format #t "Creating parent directory: ~a~%" target-dir)
|
||||
(mkdir-p target-dir)))
|
||||
|
||||
;; Remove existing directory or file
|
||||
(when (file-exists? target-path)
|
||||
(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)
|
||||
'()))
|
||||
(define (plan-operations tree target-dir)
|
||||
(let ((source-base (node-path tree)))
|
||||
(fold-tree
|
||||
(lambda (node acc)
|
||||
(let* ((relative-path (relative-path source-base (node-path node)))
|
||||
(target-path (string-append target-dir "/" relative-path)))
|
||||
(cond
|
||||
((eq? (node-type node) 'directory)
|
||||
(if (not (file-exists? target-path))
|
||||
(cons `(mkdir ,target-path) acc)
|
||||
acc))
|
||||
((eq? (node-type node) 'file)
|
||||
(if (not (file-exists? target-path))
|
||||
(cons `(symlink ,(node-path node) ,target-path) acc)
|
||||
acc))
|
||||
(else acc))))
|
||||
'()
|
||||
tree)))
|
||||
|
|
|
|||
|
|
@ -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