/ast-parser.ss

#lang scheme
;;; Documentation
;; Requirements:
;;  1. AST in XML format should be created by phc
;;  (http://www.phpcompiler.org) tool
;;  2. PLT Scheme 4.1
;;  3. it may be required to run ast-parser on php-files several times
;;  for proper functions resolving, see +function-class-name+ related
;;  things for details.
;;  4. input xml-file should not contain namespaces (i.e. sed -e
;;  's/AST://' should be executed on the file) because xml-match
;;  raises error. NOTE: it is better not to use xml-match at all :)
;;  Actually now xml-file is preprocessed and xml-match not used :)
;;
;; GLOBAL TODO:
;;  1. see TODO in the code :)
;;
;;  3. there are no variables scope:
;;
;;     3.1. example: $this->Table ($this^Table) should resolve to some
;;     value for a class (e.g., for DNSZone it should be
;;     DNSZoneTable).  As such assignment done in cObject, it is very
;;     difficult to process it automatically.  So, there should be
;;     some table (like for function
;;     "resolve-method-invocation") to define
;;     $this->smth for every class; and get-variable-definition should
;;     use this table.
;;
;;  4. [partially done] built-in functions should be highlighted (and
;;  there should be ability to hide them)
;;
;;  5. [partially done] WizardContext.php.log and many others - unable
;;  to process "Do"
;;
;;  6. [done, bugs possible] Tooltip.php.log and many others - unable
;;  to process empty method parameters (method definition)
;;
;;  7. There are no extends processing, so:
;;
;;     7.1. $this-> wronlgy resolved to the current class.  Right
;;     resolve may be done (actually it's a fake, but looks like it's
;;     enough) the following way: if class A extends class B, and B
;;     and A defines method "qwe", we should add special fake call
;;     B::qwe -> A::qwe; the diagram should represent this call
;;     special way (dotted line, for example); if class A extends
;;     class B, and B defines method "qwe" (A has no such definition),
;;     and some method of class A (e.g., A::foo) calls $this->qwe, we
;;     should add special fake call A::qwe -> B::qwe, so, there will
;;     be calls: A::foo -> A::qwe; A::qwe -> B::qwe.  Or $this->
;;     resolving should be moved to the Merge stage.
;;
;;  8. defines don't processed => some rare things may work wrong

;;; requires
(require (planet lizorkin/ssax:2:0/ssax))
(require (only-in (planet lizorkin/sxml:2:1/sxml) sxpath))
;;(require (only-in (planet jim/webit:1:6/xml) xml-match))
(require scheme/pretty)
(require scheme/match)
(require scheme/path)
(require "calls-record.ss")
(require "php-builtin-functions-hash.ss")

;;; Auxiliary functions
(define (load-xml-as-sxml filename)
  (with-input-from-file filename
    (lambda () (ssax:xml->sxml (current-input-port) '()))))

(define +ast-xml-file+ (vector-ref (current-command-line-arguments) 0))
(define +output-file+ (vector-ref (current-command-line-arguments) 1))
(define ast-xml-file (load-xml-as-sxml +ast-xml-file+))
(define +function-file-hash+ ".function-file-hash")
(define *function-to-file-relations* 
  (with-handlers ((exn? (lambda (exn) (make-immutable-hash '())))) (with-input-from-file +function-file-hash+ read)))
  
(define +processing-php-file+ (cadar ((sxpath '(// (attr 1 (@ (equal? (key "phc.filename")))) string)) ast-xml-file)))
(define (get-processing-php-file)
  (path->string (file-name-from-path +processing-php-file+)))

(define (add-method-to-function-file-hash func-name)
  (set! *function-to-file-relations* (hash-set *function-to-file-relations* func-name (get-processing-php-file))))

(define +top-class+ (get-processing-php-file))

;;; pattern processors backend
;;(define +top-class+ "{main}")
(define +top-method+ "{top}")
(define +function-class-name+ "{phpBuiltInFunctions}")

(define *current-class* +top-class+)
(define *current-method* +top-method+)
(define *current-parent* +top-class+)
(define *defined-variables* (make-hash))

(define (get-current-class) *current-class*)
(define (get-current-method) *current-method*)
(define (set-current-class val) (set! *current-class* val))
(define (set-current-method val)
  (display "\nSet current method: ") (display val) (display "\n") ;debug
  (set! *current-method* val))
(define (get-current-parent) *current-parent*)
(define (set-current-parent val) (set! *current-parent* val))

(define (get-variable-definition a-variable-name)
  (let ((no-def-handler (lambda() (if (equal? a-variable-name "this")
                                      (get-current-class)
                                      (string-append "$" a-variable-name)))))
    (hash-ref *defined-variables* a-variable-name no-def-handler)))

(define (add-variable-definition a-variable-name a-definition)
  (hash-set! *defined-variables* a-variable-name a-definition)
  (display "Variable definition added: ") (display a-variable-name) (display "  =>  ") (display a-definition) (display "\n") ;debug
  )

;; normalize unheaded list to headed sxml
(define (norm-l->sxml a-list)
  (append '(start) a-list))

;; required for xml-match to make error-reporting more useful
(define (errhandler err)
  (let ((op (open-output-string)))
    (pretty-print err op)
    (error (format "Didn't match ~n~a~n" (get-output-string op)))))

;;;

;;
(define (action-go-deep a-body)
  (map dispatch a-body))

;;
(define processor-eval-expr action-go-deep)

;;
(define (processor-class a-body)
  (display "\n---- class\n") (pretty-print a-body) ;;debug
  (let ((class-name (car ((sxpath '(CLASS_NAME value *text*)) (norm-l->sxml a-body))))
        (class-methods ((sxpath '(Member_list Method)) (norm-l->sxml a-body)))
        (a-parent ((sxpath '((CLASS_NAME 2) value *text*)) (norm-l->sxml a-body)))
        (normalize-parent (lambda(x) (if (null? x) "" (car x))))
        (old-current-class (get-current-class))
        (old-current-parent (get-current-parent))
        )
    (display "\n---- class methods\n") (pretty-print class-methods) ;;debug
    (set-current-class class-name)
    (set-current-parent (normalize-parent a-parent))
    (map dispatch class-methods)
    (set-current-class old-current-class)
    (set-current-parent old-current-parent)
    ))
  
;;
(define (processor-method a-body)
  (display "\n---- method\n") (pretty-print a-body (current-output-port)) ;;debug
  (let ((method-name (car ((sxpath '(Signature METHOD_NAME value *text*)) (norm-l->sxml a-body))))
        (method-body (car ((sxpath '(Statement_list)) (norm-l->sxml a-body))))
        (method-parameters ((sxpath '(Signature Formal_parameter_list Formal_parameter)) (norm-l->sxml a-body)))
        (old-current-method (get-current-method))
        )
    (if (eq? (get-current-class) +top-class+)
        (add-method-to-function-file-hash method-name)
        #f)
;;    (pretty-print method-body) ;debug
    (set-current-method method-name)
    ;; process method parameters to set variables to class names if specified
    (display "\n---- method parameters\n") (pretty-print method-parameters) ;debug
    (for-each
     (lambda(x)
       (display "\n---- method parameter :: \n") (pretty-print x)
       (let ((class-name ((sxpath '(Type CLASS_NAME value *text*)) x))
             (variable-name ((sxpath '(// VARIABLE_NAME value *text*)) x)))
         (if (and (not (null? class-name))
                  (not (null? variable-name)))
             (add-variable-definition (car variable-name) (car class-name))
             #f)
         ))
     method-parameters)
    ;; parse body of the method
    (dispatch method-body)
    (set-current-method old-current-method)
    )
  )

;; bin-op -> string
(define (processor-bin-op a-body)
  (let ((res ""))
    (for-each
     (lambda(a-part)
       (set! res
             (string-append
              res
              (let ((fmatch? (lambda(x) (eq? x (car a-part)))))
                (cond
                 ((fmatch? 'attrs) "")
                 ((fmatch? 'Variable) (get-variable-definition (processor-get-variable-name a-part)))
                 ((fmatch? 'OP) (if (equal? (car (cdaddr a-part)) ".") "" "##FIXME_OP_processor_bin_op##"))
                 ((fmatch? 'STRING) (car (cdaddr a-part)))
                 (#t (error (format "Unknown processor-bin-op a-part: ~a~%" a-part))))))))
     a-body)
    res))

;;
(define (generic-processor-reflection a-sxml)
  (if (null? a-sxml)
      #f
      ;; second child is variable name definition structure
      (let* ((a-body (caddar a-sxml))
             (fmatch? (lambda(x) (eq? x (car a-body)))))
        (cond
         ((fmatch? 'Bin_op) (processor-bin-op (cdr a-body)))
         ((fmatch? 'Variable) (processor-get-variable-name a-body))
         (#t (error (format "Unknown reflection operation type: ~a~%" a-sxml)))))))

;;
(define (processor-reflection/get-variable-name a-sxml)
  (display "\n---- reflection get variable name\n") (pretty-print a-sxml (current-output-port)) ;;debug
  (generic-processor-reflection a-sxml))

;; sxml -> string
(define (processor-get-variable-name a-sxml)
  ;; second child is variable prefix
  (let* ((fmatch? (lambda(x) (eq? x (caaddr a-sxml))))
         (variable-name-raw ((sxpath '(VARIABLE_NAME value *text*)) a-sxml))
         (variable-name (if (null? variable-name-raw)
                            (processor-reflection/get-variable-name ((sxpath '(Reflection)) a-sxml))
                            (car variable-name-raw)))
         )
    (cond
     ((fmatch? 'Variable) (string-append (processor-get-variable-name (caddr a-sxml)) "^" variable-name))
     ((fmatch? 'Target) variable-name)
     ((fmatch? 'Method_invocation) (resolve-method-invocation (caddr a-sxml)))
     ;; TODO: resolve "self" to (get-curent-class)
     ((fmatch? 'CLASS_NAME) (string-append (car ((sxpath '(value *text*)) (caddr a-sxml))) "^" variable-name))
     (#t (error (format "Unknown variable-prefix type: ~a for ~a~%" (caaddr a-sxml) a-sxml))))))

;;
(define (resolve-method-invocation a-sxml)
  (display "\n---- resolve-method-invocation\n") (pretty-print a-sxml (current-output-port)) ;;debug
  (let* ((i-res (processor-method-invocation (cdr a-sxml)))         
         (c-class (car i-res))
         (c-method (cdr i-res))
         (c-method? (lambda(x) (equal? x c-method)))
         (c-method-length (string-length c-method))
         (m? (lambda(x) (equal? x (string-append c-class "::" c-method)))))
    (cond
     ;; TODO: make the following list dynamically loaded according to
     ;; path of processing PHP-file
     
     ;; some special cases
     ((c-method? "objectMaker")
      ;; return first parameter because it is a class name
      (let ((a-class-name ((sxpath '(((Actual_parameter_list Actual_parameter) 1) STRING value *text*)) a-sxml)))
        (if (null? a-class-name) "##objectMaker##" (car a-class-name))))
     ;; smthMaker resolved to smth in most cases.  Exceptions of this rule should be specified above
     ((and (> c-method-length 5)
           (equal? (substring c-method (- c-method-length 5)) "Maker"))
      (substring c-method 0 (- c-method-length 5)))
     ;; smth::getInstance resolved to smth in most cases.  Exceptions of this rule should be specified above
     ((c-method? "getInstance") c-class)
     ;; TODO: now it is a hack, so, it should be rewritten to reflect c-class, not c-method only
     ((or (c-method? "getItemByClass")
          (c-method? "getParent"))
      "UIPointer")
     
     ;; just hardcoded class::methods resolving
     ((m? "Webgrind_FileHandler::getInstance") "Webgrind_FileHandler")
     ((m? "Webgrind_FileHandler::getTraceReader") "Webgrind_Reader")
     ;; if euristic doesn't found anything...
     (#t (string-append "##METHOD_INVOCATION##::" c-class "::" c-method)))))

;;
(define (processor-reflection/get-method-name a-sxml)
  (display "\n---- reflection get method name\n") (pretty-print a-sxml (current-output-port)) ;;debug
  (generic-processor-reflection a-sxml))


;; WARNING!  Performance issues may be here
(define (determine-file-name-for-invoked-func func-name)
  (hash-ref *function-to-file-relations* func-name +top-class+))

;;
(define (processor-method-invocation a-body)
  "Process method invocation and returns pair (string:class_name
. string:method_name) which was invoked"
  ;; sxml -> string
  (local ((define (get-class-name-for-invoked-func supposed-class-name func-name)
            (if (equal? supposed-class-name +function-class-name+)
                (if (hash-ref +php-builtin-functions+ func-name #f)
                    +function-class-name+
                    (determine-file-name-for-invoked-func func-name)
                    )
                supposed-class-name))
          (define (processor-get-class-name a-sxml)
            (let ((fmatch? (lambda(x) (eq? x (car a-sxml)))))
              (cond
               ((fmatch? 'Variable) (get-variable-definition (processor-get-variable-name a-sxml)))
               ((fmatch? 'Target) +function-class-name+)
               ((fmatch? 'CLASS_NAME)
                (let ((class-name (car ((sxpath '(value *text*)) a-sxml))))
                  (cond
                   ((equal? class-name "parent") (get-current-parent))
                   (#t class-name))))
               ((fmatch? 'Method_invocation)
                (resolve-method-invocation a-sxml))
               ((fmatch? 'Reflection)   ; TODO: check that here unable to be anything except variable name
                (processor-reflection/get-variable-name `(,a-sxml)))
               (#t (error (format "Unknown class-name type: ~a~%" a-sxml))))))
          ;; actual parameters list -> unspecified (side effect: processor-method-invocation calls)
          (define (processor-parameters-list a-body)
            (display "\n---- processor parameters list\n") (pretty-print a-body) ;;debug
            (let ((a-parameters ((sxpath '(Actual_parameter)) (norm-l->sxml a-body))))
              (display "\n---- processor parameters list :: parameters \n") (pretty-print a-parameters) ;;debug
              (if (null? a-parameters)
                  #f
                  (map dispatch a-parameters))))
          )
         (display "\n---- method invocation\n") (pretty-print a-body) ;;debug
         (let* ((method-name-raw ((sxpath '(METHOD_NAME value *text*)) (norm-l->sxml a-body)))
                (normalize-method-name car)
                (method-name (if (null? method-name-raw)
                                 (processor-reflection/get-method-name ((sxpath '(Reflection)) (norm-l->sxml a-body)))
                                 (normalize-method-name method-name-raw)))
               ;; class name of the invoking method described by second
               ;; element in method's AST. WARNING: if phc guys changes order
               ;; of the AST elements, class name processing algorithm will
               ;; fail.
                (class-name (get-class-name-for-invoked-func (processor-get-class-name (cadr a-body))
                                                             method-name))
                )
           
           ;; add call to calls table
           (add-call (get-current-class)
                     (get-current-method)
                     class-name
                     method-name)
           ;; debug
           (display
            (format "==[ ~a::~a -> ~a::~a~%"
                                        ;(format "==[ ~a__~a -> ~a__~a~%"
                    (get-current-class)
                    (get-current-method)
                    class-name
                    method-name))
           
           ;; process calls in parameter list
           (let (;;(old-method-name (get-current-method))
                 ;;(old-class-name (get-current-class))
                 (a-parameters-list ((sxpath '(Actual_parameter_list)) (norm-l->sxml a-body))))
             (if (null? a-parameters-list)
                 #f
                 (begin
                   ;;(set-current-method method-name)
                   ;;(set-current-class class-name)
                   (processor-parameters-list (cdar a-parameters-list))
                   ;;(set-current-class old-class-name)
                   ;;(set-current-method old-method-name)
                   )))
           
           ;; return pair class-name method-name
           (cons class-name method-name)
           )))

;; TODO: make it more correct way
(define (processor-new a-body-raw)
  (display "\n---- processor-new\n") (pretty-print a-body-raw (current-output-port)) ;;debug

  (let* ((value-struct (if (list? (car a-body-raw)) (norm-l->sxml a-body-raw) a-body-raw))
         (a-body (cdr value-struct))
         (class-name-raw ((sxpath '(CLASS_NAME value *text*)) value-struct))
         (class-name (if (null? class-name-raw)
                         (processor-reflection/get-class-name ((sxpath '(Reflection)) value-struct))
                         (car class-name-raw))))
    (processor-method-invocation (append (list (car a-body) (cadr a-body) '(METHOD_NAME (value "__construct"))) (cddr a-body)))
    (processor-method-invocation (append (list (car a-body) (cadr a-body) `(METHOD_NAME (value ,class-name))) (cddr a-body)))
    class-name))

;;
(define (processor-reflection/get-class-name a-sxml)
  (display "\n---- reflection get class name\n") (pretty-print a-sxml (current-output-port)) ;;debug
  (generic-processor-reflection a-sxml))
  
;; assign value to variable;
;; Note: as variables are interesting only for $qwe->asd() cases,
;; valid assigment makes sense only if value resolves to class name
;; TODO: make visibility scope
(define (processor-assigment a-body)
  ;; sxml -> string
  (define (processor-get-variable-value value-struct)
    (display "\n---- assignment :: processor get variable value\n") (pretty-print value-struct (current-output-port)) ;;debug
    (let ((fmatch? (lambda(x) (eq? x (car value-struct)))))
      (cond
       ((fmatch? 'Method_invocation) (resolve-method-invocation value-struct))
       ((fmatch? 'Variable) (get-variable-definition (processor-get-variable-name value-struct)))
       ((fmatch? 'New)
        (processor-new value-struct))
       ;; other types not interesting
       (#t (string-append "##" (symbol->string (car value-struct)) "##")))))
  (display "\n---- assignment\n") (pretty-print a-body (current-output-port)) ;;debug
  ;; variable to assign is second child.  value is last child
  (let ((variable-name (processor-get-variable-name (cadr a-body)))
        (value-struct (car ((sxpath '((*any* -1))) (norm-l->sxml a-body)))))
    (add-variable-definition variable-name (processor-get-variable-value value-struct)))
  )

;; variable to assign is second child.  value is last child.  so, it
;; is suitable to use just processor-assignment
(define processor-op-assignment processor-assigment)

;; TODO
(define (processor-list-assignment a-body)
  (display "\n---- list assignment\n") (pretty-print a-body (current-output-port)) ;;debug
  )


;;
(define (processor-switch a-body)
  (display "\n---- switch\n") (pretty-print a-body) ;;debug
  (let ((list-to-process ((sxpath '(Switch_case_list Switch_case Statement_list)) (norm-l->sxml a-body)))
        )
    (display "\n---- switch-statement\n") (pretty-print list-to-process) ;;debug
    (map dispatch list-to-process)))

;;
(define (generic-processor-statement a-body)
  (let ((list-to-process ((sxpath '(Statement_list)) (norm-l->sxml a-body))))
    (map dispatch list-to-process)))

;;
(define (generic-processor-header a-body)
  ;; all childs from second inclusively to Statement_list exclusively
  ;; are header; below is dirty code, but it works...
  (let* ((add? #t)
    ;; first child is always attrs, we reject it via cdr
    ;; reverse required because of cons
         (headers (cdr (reverse (fold (lambda(x y)
                                        (if (eq? (car x) 'Statement_list) (set! add? #f) '())
                                        (if add? (cons x y) y))
                                      '()
                                      a-body)))))
    (map dispatch headers)))
  
;;   ;; second child is the header
;;   (dispatch (cadr a-body)))

;;
(define (processor-if a-body)
  (display "\n---- if\n") (pretty-print a-body) ;;debug
  (generic-processor-header a-body)
  (generic-processor-statement a-body))

;;
(define (processor-foreach a-body)
  (display "\n---- foreach\n") (pretty-print a-body) ;;debug
  (generic-processor-header a-body)
  (generic-processor-statement a-body))

;;
(define (processor-for a-body)
  (display "\n---- for\n") (pretty-print a-body) ;;debug
  (generic-processor-header a-body)
  (generic-processor-statement a-body))

;;
(define (processor-while a-body)
  (display "\n---- while\n") (pretty-print a-body) ;;debug
  (generic-processor-header a-body)
  (generic-processor-statement a-body))

;; TODO: inside do footer can be calls, they should be processed
(define (processor-do a-body)
  (display "\n---- do\n") (pretty-print a-body) ;;debug
  (generic-processor-statement a-body))

;;
(define (processor-return a-body)
  (display "\n---- return\n") (pretty-print a-body) ;;debug
  ;; the second child is the return body, and should be processed as action-go-deep
  (action-go-deep a-body))

;;
(define (processor-try a-body)
  (display "\n---- try\n") (pretty-print a-body) ;;debug
  (generic-processor-statement a-body)
  ;; process catch list because it can contain method invocations
  (let ((catch-list (cdar ((sxpath '(Catch_list)) (norm-l->sxml a-body)))))
    (display "\n---- catch-list\n") (pretty-print catch-list) ;debug
    (map (lambda(x)
           (display "\n---- catch-item\n") (pretty-print x) ;debug
           (generic-processor-statement (cdr x)))
         catch-list)))

;; symbol -> function
(define (processor-dispatcher fragment-type)
  "Determine function to parse sxml fragment according to type"
  (let ((fmatch? (lambda(x) (eq? fragment-type x)))
        (action-stop (lambda(x) '())))
    (cond
     ((fmatch? 'PHP_script) action-go-deep)
     ((fmatch? 'attrs) action-stop)
     ((fmatch? 'bool) action-stop)
     ((fmatch? 'Statement_list) action-go-deep)
     ((fmatch? 'Static_declaration) action-go-deep)
     ((fmatch? 'Eval_expr) processor-eval-expr)
     ((fmatch? 'Expr) action-go-deep)
     ((fmatch? 'Conditional_expr) action-go-deep)
     ((fmatch? 'Method) processor-method)
     ((fmatch? 'If) processor-if)
     ((fmatch? 'Assignment) processor-assigment)
     ((fmatch? 'Op_assignment) processor-op-assignment)
     ((fmatch? 'List_assignment) processor-list-assignment)
     ((fmatch? 'Method_invocation) processor-method-invocation)
     ((fmatch? 'Name_with_default_list) action-stop) ; TODO: processor should be assignment-like
     ((fmatch? 'Global) action-stop)    ; TODO: processor should be assigment-like
     ((fmatch? 'Return) processor-return)
     ((fmatch? 'Switch) processor-switch)
     ((fmatch? 'Break) action-stop)
     ((fmatch? 'Class_def) processor-class)
     ((fmatch? 'Foreach) processor-foreach)
     ((fmatch? 'Continue) action-stop)
     ((fmatch? 'Throw) action-go-deep)
     ((fmatch? 'New) processor-new)
     ((fmatch? 'Nop) action-stop)
     ((fmatch? 'For) processor-for)
     ((fmatch? 'While) processor-while)
     ((fmatch? 'Do) processor-do)
     ((fmatch? 'Try) processor-try)
     ((fmatch? 'Ignore_errors) action-go-deep)
     ((fmatch? 'Bin_op) action-go-deep)
     ((fmatch? 'Post_op) action-stop)   ; TODO: check that there unable to be methods invocations
     ((fmatch? 'Pre_op) action-stop)   ; TODO: check that there unable to be methods invocations
     ((fmatch? '@) action-stop) ;TODO: check that there unable to be methods invocations
     ((fmatch? 'Interface_def) action-stop)
     ((fmatch? 'Actual_parameter) action-go-deep)
     ((fmatch? 'Array) action-go-deep)
     ((fmatch? 'Array_elem_list) action-go-deep)
     ((fmatch? 'Array_elem) action-go-deep)
     ((fmatch? 'Cast) action-go-deep)
     ((fmatch? 'CAST) action-go-deep) ; TODO: what is the difference between Cast and CAST?

     ;; the following types may appear only inside some context
     ;; (header is most probably place to meet they)
     ((fmatch? 'Variable) action-stop)
     ((fmatch? 'INT) action-stop)
     ((fmatch? 'REAL) action-stop)
     ((fmatch? 'OP) action-stop)
     ((fmatch? 'Unary_op) action-go-deep)
     ((fmatch? 'STRING) action-stop)
     ((fmatch? 'BOOL) action-stop)
     ((fmatch? 'Constant) action-stop)
     ((fmatch? 'NIL) action-stop)
     ((fmatch? 'value) action-stop)
     ((fmatch? 'Instanceof) action-stop) ; TODO: check that there unable to be methods invocations

     (#t
      (lambda(x)
        (error (format "Unknown type: ~a~%Body: ~s~%" fragment-type x)))))))

(define (dispatch a-sxml)
  ((processor-dispatcher (car a-sxml)) (cdr a-sxml)))


;;; main
(display (format "Processing ~a~%" +ast-xml-file+)) ;;debug

(dispatch (caddr ast-xml-file))

(local ((define (write-to-output-file) (write *calls*)))
       (with-output-to-file +output-file+
         write-to-output-file #:exists 'replace))

(local ((define (write-to-output-file) (write *function-to-file-relations*)))
       (with-output-to-file +function-file-hash+
         write-to-output-file #:exists 'replace))