Megatest

Diff
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Annotate Patch Side-by-side Diff

Differences From Artifact [8dcb81c313]:

To Artifact [6fde3f5b9e]:

︙
53
54
55
56
57
58
59
60

61
62
63
64
65
66





67
68

69
70
71
72
73
74
75

53
54
55
56
57
58
59

60
61





62
63
64
65
66


67
68
69
70
71
72
73
74








-
+

-
-
-
-
-
+
+
+
+
+
-
-
+










;;
;; GLOBALS
;;
(define *spublish:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define spublish:help (conc "Usage: spublish [action [params ...]]
(define spublish:help (conc "Usage: spublish  [action [params ...]]

  ls                     : list contents of target area
  cp|publish <src file> <destination>      : copy file to target area
  mkdir <dir name>       : maks directory in target area  
  rm <file>              : remove file <file> from target area
  ln <target> <link name> : creates a symlink
  ls       <area>              : list contents of target area
  cp|publish <area> <src file> <destination>      : copy file to target area
  mkdir <area> <dir name>       : maks directory in target area  
  rm <area> <file>              : remove file <file> from target area
  ln <area> <target> <link name> : creates a symlink
  log                    :

 
  options:

    -m \"message\"        : describe what was done
Note: All the target locations relative to base path 
Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest
︙
416
417
418
419
420
421
422
423


424
425
426
427
428
429
430
431
432
433
434
435


436
437
438
439
440
441
442

415
416
417
418
419
420
421

422
423
424
425
426
427
428
429
430
431
432
433


434
435
436
437
438
439
440
441
442








-
+
+










-
-
+
+








            (let* ((parent-dir src-path)
                   (start-dir target-path))
                 ;(print "parent-dir " parent-dir " start-dir " start-dir)   
                 (run (pipe
                   (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
                   (begin (change-directory start-dir)
                          ;(print "123")
                          (run-cmd "tar" (list "xf" "-"))))))) 
                          (run-cmd "tar" (list "xf" "-")))))
                          (print "Copied data to " start-dir))) 
        (begin
           (let*((parent-dir (pathname-directory src-path))
                  (start-dir target-path)
                (filename (if  (pathname-extension src-path)  
                                      (conc(pathname-file src-path) "." (pathname-extension src-path))
                                      (pathname-file src-path))))
                ;(print "parent-dir " parent-dir " start-dir " start-dir)   
                 (run (pipe
                   (begin (system (conc "cd " parent-dir ";tar chf - " filename )))
                   (begin (change-directory start-dir)
                          (run-cmd "tar" (list "xf" "-"))) 
                  ))))))))
                          (run-cmd "tar" (list "xf" "-")))))
                          (print "Copied data to " start-dir)))))))


(define (spublish:shell-mkdir targ-path)
    (if (file-exists? targ-path)
	(begin
	  (print "ERROR: target Directory " targ-path " already exist!!"))
        (let* ((th1         (make-thread
︙
690
691
692
693
694
695
696
697

698
699
700
701
702
703













704
705
706

707
708

709
710

711
712


713
714
715
716
717
718
719



720
721

722
723
724


725
726
727
728
729
730
731






732
733

734

735
736
737
738
739






740
741
742



743
744
745
746
747
748

749
750



751
752

753
754

755

756
757
758
759
760
761









762
763

764
765

766
767
768
769

770
771
772

773
774

775
776

777
778
779

780
781
782

783
784
785
786
787
788
789
790


791
792
793
794
795
796

797
798
799


800
801
802
803
804

805
806
807
808
809
810

811
812
813


814
815
816
817
818
819
820
821
822
823
824


825
826
827
828
829

830
831
832
833
834
835
836
837
838

690
691
692
693
694
695
696

697






698
699
700
701
702
703
704
705
706
707
708
709
710
711
712

713
714

715
716

717


718
719
720
721
722
723
724


725
726
727


728



729
730







731
732
733
734
735
736
737

738
739
740





741
742
743
744
745
746



747
748
749






750


751
752
753
754

755
756

757
758
759






760
761
762
763
764
765
766
767
768


769


770




771



772
773

774
775

776
777


778



779








780
781






782



783
784





785






786



787
788











789
790
791
792
793
794

795


796
797
798
799
800
801
802








-
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+


-
+

-
+

-
+
-
-
+
+





-
-
+
+
+
-
-
+
-
-
-
+
+
-
-
-
-
-
-
-
+
+
+
+
+
+

-
+

+
-
-
-
-
-
+
+
+
+
+
+
-
-
-
+
+
+
-
-
-
-
-
-
+
-
-
+
+
+

-
+

-
+

+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
+
-
-
+
-
-
-
-
+
-
-
-
+

-
+

-
+

-
-
+
-
-
-
+
-
-
-
-
-
-
-
-
+
+
-
-
-
-
-
-
+
-
-
-
+
+
-
-
-
-
-
+
-
-
-
-
-
-
+
-
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
+
+




-
+
-
-








    ;; (ini:property-separator #\space)
    (if (file-exists? fname)
	;; (ini:read-ini fname)
	(read-config fname #f #t)
	(make-hash-table))))

(define (spublish:process-action action . args)
  (let* (
  ;(print args)
         ;; (target-dir    (configf:lookup configdat "settings" "target-dir"))
	 (user          (current-user-name))
	 ;;(allowed-users (string-split
	;;		 (or (configf:lookup configdat "settings" "allowed-users")
	;;		     "")))
)
  (let* ((usr          (current-user-name))
         (user-obj (get-user usr)) 
         (area   (car args))
         (area-obj  (get-obj-by-code area))
         (top-areas (spublish:get-accessable-projects area))  
         (base-path (if (null? area-obj) 
                         "" 
                        (caddr (cdr area-obj))))   
         (remargs (cdr args)))
     (if (null? area-obj)
          (begin 
             (print "Area " area " does not exist")
          (exit 1)))
    (case (string->symbol action)
      ((cp publish)
       (if (< (length args) 2)
       (if (< (length remargs) 2)
	   (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (print "ERROR: Missing arguments; spublish <area> <src file> <destination>" )
	     (exit 1)))
       (let* ((remargs     (args:get-args args '("-m") '() args:arg-hash 0))
       (let* ((filter-args     (args:get-args args '("-m") '() args:arg-hash 0))
              (dest-dir (cadr args))
              (src-path-in (car args))
              (src-path-in (car filter-args))
              (dest-path (cadr filter-args))
	      (src-path    (with-input-from-pipe
			    (conc "readlink -f " src-path-in)
			    (lambda ()
			      (read-line))))
	      (msg         (or (args:get-arg "-m") ""))
	      (targ-file   (pathname-strip-directory src-path)))
	 (if (not (file-read-access? src-path))
              (resolved-path (sauth-common:resolve-path  (conc area "/" dest-path) `() top-areas))
              (target-path (sauth-common:get-target-path `()  (conc area "/" dest-path) top-areas base-path)))
 	     (if (not (equal? target-path #f))
	     (begin
	       (print "ERROR: source file not readable: " src-path)
                 (if (equal? resolved-path #f)     
	       (exit 1)))
	 (if (directory? src-path)
	     (begin
                    (print "Invalid argument " dest-path ".. ")
                    (begin 
              (print "ERROR: source file is a directory, this is not supported yet.")
	       (exit 1)))
	     (print "publishing " src-path-in " to " target-dir)
             (spublish:validate     target-dir dest-dir)
	     (spublish:cp configdat user src-path target-dir targ-file dest-dir msg)))
      ((tar)
        (if (< (length args) 1)
                      (spublish:shell-cp src-path target-path)   
                      (sauthorize:do-as-calling-user
                      (lambda ()
		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" cp " src-path-in " " dest-path  "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "cp")))))))))   
      ((mkdir)
        (if (< (length remargs) 1)
          (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (print "ERROR: Missing arguments; <area> <path>")
	     (exit 1)))
        (let* ((filter-args     (args:get-args args '("-m") '() args:arg-hash 0))
        (let* ((dst-dir (car args))
               (msg         (or (args:get-arg "-m") "")))
               (spublish:validate     target-dir  dst-dir)
               (spublish:tar configdat user target-dir dst-dir msg)))
 
               (mk-path (car filter-args))
               (msg         (or (args:get-arg "-m") ""))
               (resolved-path (sauth-common:resolve-path  mk-path (list area) top-areas))
               (target-path (sauth-common:get-target-path (list area)  mk-path top-areas base-path))) 
               (print "attempting to create directory " mk-path  )
               (if (not (equal? target-path #f))
      ((mkdir)
        (if (< (length args) 1)
          (begin 
                 (if (equal? resolved-path #f)     
                   (print "Invalid argument " mk-path ".. ")
                   (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1)))
        (let* ((targ-mk (car args))
               (msg         (or (args:get-arg "-m") ""))) 
               (print "attempting to create directory " targ-mk " in " target-dir)
               (spublish:validate     target-dir targ-mk)
                     (spublish:shell-mkdir target-path)   
               (spublish:mkdir configdat user target-dir targ-mk msg)))

                     (sauthorize:do-as-calling-user
                       (lambda ()
		        (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" mkdir " mk-path  "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "mkdir")))))))))  
      ((ln) 
        (if (< (length args) 2)
        (if (< (length remargs) 2)
          (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (print "ERROR: Missing arguments;  <area> <target> <link name>" )
	     (exit 1)))
        (let* ((filter-args     (args:get-args args '("-m") '() args:arg-hash 0))
        (let* ((targ-link (car args))
               (link-name (cadr args))  
               (sub-path (string-reverse (string-join (cdr (string-split (string-reverse link-name) "/")) "/"))) 
               (msg         (or (args:get-arg "-m") "")))
               (if (> (string-length(string-trim sub-path)) 0)
                (begin 
              (src-path (car filter-args))
              (dest-path (cadr filter-args))   
              (resolved-path (sauth-common:resolve-path  dest-path (list area) top-areas))
              (target-path (sauth-common:get-target-path  (list area)  dest-path top-areas base-path))
              (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse  target-path) "/")) "/")))))
               (if (not (equal? target-path #f))
                  (if (equal? resolved-path #f)     
                    (print "Invalid argument " dest-path ".. ")
                    (begin 
                  (print "attempting to create directory " sub-path " in " target-dir)
                  (spublish:validate     target-dir sub-path)
                   (spublish:shell-ln src-path target-path sub-path)   
                  (print (conc target-dir "/" sub-path ) )
                  (print (directory-exists?(conc target-dir "/" sub-path )))
                  (sauthorize:do-as-calling-user
                  (if (directory-exists?(conc target-dir "/" sub-path ))
                   (print "Target Directory " (conc target-dir sub-path ) " exist!!")
                  (spublish:mkdir configdat user target-dir sub-path msg))))

                 (lambda ()
               (print "attempting to create link " link-name " in " target-dir)
               (spublish:ln configdat user target-dir targ-link link-name msg)))

		   (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" ln " src-path " " dest-path  "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "ln")))))))))
      ((rm)
       (if (< (length args) 1)
       (if (< (length remargs) 1)
	   (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (print "ERROR: Missing arguments; <area> <path> ")
	     (exit 1)))
       (let* ((targ-file (car args))
	      (msg         (or (args:get-arg "-m") "")))
       (let* ((filter-args  (args:get-args args '("-m") '() args:arg-hash 0))
	 (print "attempting to remove " targ-file " from " target-dir)
           (spublish:validate     target-dir targ-file)

              (rm-path (car filter-args))
	 (spublish:rm configdat user target-dir targ-file msg)))
      ((publish)
       (if (< (length args) 3)
	   (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1))
	   (let* ((srcpath  (list-ref args 0))
		  (areaname (list-ref args 1))
              (resolved-path (sauth-common:resolve-path  rm-path (list area) top-areas))
              (target-path (sauth-common:get-target-path (list area)  rm-path top-areas base-path)))
		  (version  (list-ref args 2))
		  (remargs  (args:get-args (drop args 2)
					   '("-type" ;; link or copy (default is copy)
					     "-m")
					   '()
					   args:arg-hash
	       (if (not (equal? target-path #f))
					   0))
		  (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
		  (comment      (or (args:get-arg "-m") ""))
                                 (if (equal? resolved-path #f)     
                                 (print "Invalid argument " rm-path ".. ")
		  (submitter    (current-user-name))
		  (quality      (args:get-arg "-quality"))
		  (publish-res  (spublish:publish configdat publish-type areaname version comment srcpath submitter quality)))
	     (if (not (car publish-res))
		 (begin
                                  (begin 
		   (print "ERROR: " (cdr publish-res))
		   (exit 1))))))
      ((list-versions)
       (let ((area-name (car args)) ;;      version patt   full print
	     (remargs   (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
	     (db        (spublish:open-db configdat))
                                      (spublish:shell-rm target-path)   
	     (versions  (spublish:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
	 ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
	 (map (lambda (x)
                                      (sauthorize:do-as-calling-user
                              (lambda ()
		(if (args:get-arg "-full")
		    (format #t 
			    "~10a~10a~4a~27a~30a\n"
			    (vector-ref x 0)
			    (vector-ref x 1) 
			    (vector-ref x 2) 
			    (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
			    (conc "\"" (vector-ref x 4) "\""))
		    (print (vector-ref x 0))))
	      versions)))
       ((shell)
			    (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" rm " rm-path "\"") (number->string (car user-obj))  (number->string (caddr area-obj))  "rm")))))))))
      ((shell)
          (if (< (length args) 1)
             (begin 
	     (print  "ERROR: Missing arguments area!!" )
	     (exit 1))
             (spublish:shell (car args)))
             (spublish:shell area))) 
       ) 
   
      (else (print "Unrecognised command " action)))))
  
;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.spublishrc")))
;;   (if (file-exists? debugcontrolf)
;;       (load debugcontrolf)))
︙
This page was generated in about 0.106s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00