REBOL [
   Title: "Patches"
   Date:  1999-11-19
   Purpose: {Patches for system functions,
        now for version 2.2}
   File: %Patches.r
;;   Needs: 2.2
   Author: "Ingo Hohmann"
   Email:  ingo@2b1.de
   Site:   http://www.2b1.de/
   Rights: "(c) Ingo Hohmann and others"
   Comments: {Some functions by
         - Allen Kamp <allenk@powerup.com.au>
         - Andrew Martin <Al.Bri@xtra.co.nz>
         - Bohdan Lechnowsky <bo@rebol.com>
     This file contains patches to system functions,
     in other words, protect-system will prevent this
     script from being run}
   Usage: {place: do %Patches.r in your %user.r}
   Category: 'Utility
]

; Oooops
;unprotect-system

;
; by Andrew Martin
;
; NOT A PATCH, BUT USED HERE
Redefine: func ['OldWord [word!] 'NewWord [word!]] [
   if not value? NewWord [
      set NewWord get in system/words OldWord
   ]
]

;
; Confirm with /yes giving true as default, /no giving false
;

redefine confirm confirm-original

confirm: func [
   "Confirm a user choice. *PATCHED* (iho)" [catch]
   question [series!] "Prompt to user"
   /yes "Default is yes"
   /no  "Default is no"
   /with choices [string! block!]
   /local response match-multiple ret-def
][
   ret-def: func [] [
      if yes [return true]
      if no [return false]
      return none
   ]
   match-multiple: func [choices] [
      use [yes no] [
         set [yes no] choices
         if find yes response [return true]
         if find no response [return false]
         ret-def
      ]
   ]
   if all [with 2 < length? choices] [
      throw make error! reduce ['script 'invalid-arg mold choices]
   ]
   response: ask question
   if not with [choices: [["y" "yes"] ["n" "no"]]]
   all [empty? choices return true]
   all [string? choices
      return either find/match response choices [true] [ret-def]]
   all [2 > length? choices
      return either find/match response first choices [true] [ret-def]]
   all [2 = length? choices return match-multiple choices]
]

;
; email
;
; #1411
History: [
      [22-Nov-1999 "iho" {always close smtp-port}
      {multiline header fields are started with " "}]
      [17-Nov-1999 "iho" {"^/." lines are escaped with "^/.."} ]
      [16-Nov-1999 "iho" {bcc/cc are handled} ]
      [11-Nov-1999 "iho" {address block of the form [ [name] email ... ]
         may now be used (name may be omitted).}
      {Now address blocks in header-objects are interpreted correctly}]
      [13-Sep-1999 "iho" {Added send "REALNAME <email@domain>" message
                   and Signature (to be set in system/user/signature)}]
      [6-Sep-1999 "iho" {re-introduced my original version, you
        may just move the comment mark, if you wish}]
      [31-Aug-1999 "Allen Kamp" {Modified From output to include ""
         as in "User Name" <user@wherever.com>}]
      [8-Aug-1999 "iho" {Original Release} ]
]
send: func [
   {Send a message to an address (or block of addresses)
patched by iho, to include your real name when sending, 
this has to be set as system/user/name *PATCHED* (iho)}
   address [email! block!] "An address, block of addresses, or string"
   message "Text of message. First line is subject."
   /only "Send only one message to multiple addresses"
   /header "Supply your own custom header"
   header-obj [object!] "The header to use"
   ;
   ;;;;;;;;;;;
   /subject "Supply extra Subject"
   subj [string!]
   /no-sig "Don't add signature"
   ;;;;;;;;;;;
   ;
   /local smtp-port do-send addr-list bcc cc msg create-from
   escape-dots next-addr err
][
   ;Helpers
   escape-dots: [ any [to "^/." mark: ( insert next mark
            ".") skip ] to end]
   do-send: func [port data] [insert port reduce data]
   create-from: func [name email /local from] [
      either none? name [
         From: email
      ][
         ; This is from "Allen Kamp" <allenk@powerup.com.au>
         From: rejoin [{"} name {" <} email ">"]
      ]
      from
   ]
   next-addr: func [[catch]
      addr-block [block!]
      /local addr
   ] [
      if tail? addr-block [ return none ]
      addr: first addr-block
      remove addr-block
      if string? addr [
         either email? pick addr-block 1 [
            addr: rejoin [ {"} addr {" <} first addr-block {>} ]
            remove addr-block
            return addr
         ][
            net-error rejoin [ "Error: Name without email (" addr ")" ]
         ]
      ]
      if email? addr [
         addr: rejoin ["" addr ]
         return addr
      ]
      net-error "Wrong type in address block"
   ]

   ;Variables
   if not block? address [address: reduce [address]]
   message: either string? message [copy message] [mold message]
   ; content deleted

   ; I use these, to merge header-obj's address fields
   bcc: copy []
   cc: copy []

   ;
   ;;;;;;;;;;;;;; This is only to add a signature
   if all [not no-sig
      found? find copy next first system/user 'signature
      not none? system/user/signature
   ] [
      insert tail message rejoin [ "^/" system/user/signature ]
   ]
   ;;;;;;;;;;;;;;
   ;

   ; to change "^/.^/" to "^/..^/"
   parse message escape-dots

   ; set header fields
   either not header [
      header-obj: make system/standard/email [
         Subject: copy/part message any [find message newline 50]
      ]
   ] [
      ; I want to be sure, not to change the header given to me!
      header-obj: make header-obj []
   ]

   ;
   ;;;;;;;;;;; To set the subject specifically
   if subject [header-obj/Subject: subj]
   ;;;;;;;;;;;
   ;

   if none? header-obj/date [header-obj/date: to-idate now]
   either none? header-obj/from [
      if none? system/user/email [
         net-error {Can't set Email header: 
              neither system/user/email nor from address set}
      ]
      header-obj/From: create-from system/user/name system/user/email
   ] [
      either email? header-obj/from [
         header-obj/from: create-from none header-obj/from
      ] [
         either block? header-obj/from [
            either 2 = length? header-obj/from [
               header-obj/from: create-from first header-obj/from
               second header-obj/from
            ] [
               header-obj/from: create-from none first header-obj/from
            ]
         ] [ ; block
            net-error "Wrong type in From: field"
         ]
      ]
   ]

   ; set address-lists (bcc/cc)
   either only [
      append cc address
      if not none? header-obj/to [ append cc header-obj/to ]
   ][
      append bcc address
      if not none? header-obj/to  [ append bcc header-obj/to ]
   ]
   if not none? header-obj/cc [
      append cc header-obj/cc
      header-obj/cc: none
   ]
   if not none? header-obj/bcc [
      append bcc header-obj/bcc
      header-obj/bcc: none
   ]
   ; FIXME: should possible validity tests be done now?

   ; now do the sending
   ; open smtp-port, now that it is needed
   smtp-port: open [scheme: 'smtp]
   if error? err: try [
      if not tail? cc [
         addr-list: copy ""
         do-send smtp-port ["MAIL FROM: "  header-obj/from ]
         until [
            if not none? addr: next-addr cc [
               do-send smtp-port [{RCPT TO: } addr ]
               either tail? addr-list [
                  append addr-list addr
               ][
                  append addr-list join ", " addr
               ]
            ]
            tail? cc
         ] ; until
         header-obj/to: addr-list
         msg: rejoin [ net-utils/export header-obj newline message ]
         do-send smtp-port ["DATA" msg]
      ]
      while [not tail? bcc] [
         addr: next-addr bcc
         if not none? addr [
            do-send smtp-port ["MAIL FROM: " header-obj/from ]
            do-send smtp-port ["RCPT TO: " addr ]
            header-obj/to: addr
            msg: rejoin [ net-utils/export header-obj newline message ]
            do-send smtp-port ["DATA" msg]
         ]
      ]
      true
   ][
      ; be sure to close port, even if error
      close smtp-port
      print "While trying to send email:"
      err
   ]
   close smtp-port
]


; scan email address headers, and give back a block of
; realname/email pairs, or email only
Mail-List-Rules: make object! [
   addr-list: none
   addy: none
   addr: none
   name: none
   mailbox: [
      copy addy [to "," | to ";" | to end] (
         if not none? addy [
            parse addy [
               "(" copy name to ")" skip copy addr |
               {"} copy name to {"} thru "<" copy addr to ">" |
               copy name to "<" skip copy addr to ">" skip |
               copy addr to "(" skip copy name to ")" skip |
               copy addr to end
            ]
         ]
      )
   ]
   maillist: [
      mailbox (if not none? name [
            append addr-list trim name]
         append addr-list to-email trim addr)
         [[thru "," | thru ";"] maillist | none]
   ]
   parse-mail-list: func [
        {Mail-List-Rules *PATCHED* (iho)}
      data [string!]
   ][
      addr-list: make block! 1
      parse data maillist
      addr-list
   ]
]


;#1409
; scans multiline headers, even if " "/"^-" is missing at the start
; of subsequent lines
header-rules:  make object! [
   full-line: none
   head-list: none
   field-chars: make bitset! #{
000000000060FF03FEFFFF87FEFFFF0700000000000000000000000000000000
}
   cont-line: [
      copy line to newline (
         append last head-list trim any [line ""]
      )
      newline
   ]
   head-line: [
         [copy name some field-chars ":" [some " " | none] ] (
         insert tail head-list make set-word! name
      )
      copy line to newline
         (
         insert tail head-list trim any [line ""]
      )
      newline
   ]
   header: [
         [head-line | cont-line ] header | thru newline
   ]
   content: [
      full-line: (
         insert insert tail head-list make set-word! "content" full-line
      )
      to end
   ]
   ; to cope with mbox like "From ..." line at the start
   start: [["From " thru newline] | none ]
   parse-head: func [
      parent [object! none!]
      data [any-string!]
   ][
      head-list: make block! 10
      if not parse/all data [start header content] [
         net-error "header not correctly parsed"
      ]
      make either parent [parent] [object!] head-list
   ]
]

; Now headers will get a space character
; at the start of subsequent lines
net-utils: make net-utils [
   export: func [
      {Export an object to something that looks like a header *PATCHED* (iho)}
      object [object!] "Object to export"
      /local words values result word val
   ][
      multi-line-rule: [ any [to "^/" mark:
               (mark: next :mark if not any [(" " = first mark)
                     ("^-" =  first mark)] [
                  insert :mark  " "]) skip ] to end]
      words: next first object
      values: next second object
      result: make string! (20 * length? words)
      foreach word words [
         if found? first values [
            val: first values
            parse val multi-line-rule
            insert tail result reduce [word ": " val newline ]
         ]
         values: next values
      ]
      result
   ]
]


;
; help on paths
;

; added repend, so it works on /Core, too
repend: func [
   {Appends a reduced value to a series and returns the series head.}
   series [series! port!]
   value
   /only "Appends a block value as a block"
][
   head either only [insert/only tail series reduce :value
   ] [
      insert tail series reduce :value
   ]
]

help: func [
   "Prints information about words and values."
   'word [any-type!]
   /local value args item name refmode types attrs rtype type-name
][
   if unset? get/any 'word [
      print trim/auto {
^-^-^-^-The help function provides a simple way to get
^-^-^-^-information about words and values.  To use it
^-^-^-^-supply a word or value as its argument:
^-^-^-^-
^-^-^-^-^-help insert
^-^-^-^-^-help find

^-^-^-^-To view all words that match a pattern:

^-^-^-^-^-help "path"
^-^-^-^-^-help to-

^-^-^-^-To view all words of a specified datatype:

^-^-^-^-^-help native!
^-^-^-^-^-help datatype!

^-^-^-^-There is also word completion from the command
^-^-^-^-line.  Type a few chars and press TAB to complete
^-^-^-^-the word.  If nothing happens, there is more than
^-^-^-^-one word that matches.  Enough chars are needed
^-^-^-^-to uniquely identify the word.

^-^-^-^-Other useful functions:

^-^-^-^-^-about - for general info
^-^-^-^-^-usage - for the command line arguments
^-^-^-^-^-license - for the terms of user license
^-^-^-^-^-source func - print source for given function
^-^-^-^-^-upgrade - updates your copy of REBOL
^-^-^-^-
^-^-^-^-For more information, see the user guides.
^-^-^-}
      exit
   ]

   if all [word? :word not value? :word] [word: mold :word]

   if any [string? :word all [word? :word datatype? get :word]] [
      types: copy []
      attrs: second system/words
      foreach item first system/words [
         value: copy "              "
         change value :item
         if all [not unset? first attrs
            any [
               all [string? :word find value word]
               all [not string? :word datatype? get :word (get :word) = type? first attrs]
            ]
         ] [
            repend value [" (" type? first attrs ")"]
            append types value
         ]
         attrs: next attrs
      ]
      sort types
      if not empty? types [
         print "Found these words:"
         foreach item types [print [tab item]]
         exit
      ]
      print ["No information on" word "(word has no value)"]
      exit
   ]
   type-name: func [value] [
      value: mold type? :value
      clear back tail value
      join either find "aeiou" first value ["an "] ["a "] value
   ]

   ; \/ \/ \/ start changes by iho

   if all [ word? :word object? get :word ] [ word: get :word ]

   if not word? :word [

      ; check for path first, the value? check wouldn't work on a path!
      if path? :word [

         ;; uncomment this, to exclude system/words ...

         ;if "system/words" = to-string compose [ (:word) ] [
         ;      print "Sorry, this function is not able to work on system/words" exit
         ;]

         use [
            obj   ; the "valid" path (last path part, that's not a refinement) as object!
            parts ; block containing the paths parts
            i     ; position in path
            j     ; loop variable
            pth   ; valid path for printing as path!
         ] [

            ; split the path ...
            parts: parse mold :word "/"

            ; and find out, if first element of path exists
            if error? try [obj: get to-word first parts] [
               print ["Path:" :word "not found"]
               obj: to-word first parts
               help :obj
               exit
            ]

            ; find the last part of the path, that exists, and is no refinement
            i: 2
            while [all [object? :obj i <= length? parts] ] [
               ; when error here, it's first refinement (or nonsense)
               either not error? try [obj: get in obj to-word pick parts i] [
                  i: i + 1
               ] [
                  break
               ]
            ]

            ; build the path for printing
            pth: first parts
            for j 2 i - 1 1 [
               append pth rejoin ["/" pick parts j ]
            ]

            prin rejoin [{Valid subpath "} pth]

            ; Test whether what we found is a function and call help accordingly ...
            either any-function? :obj [
               print rejoin [{" is } form type? :obj ":^/" ]
               help 'obj
            ][
               either object? :obj [
                  print {" is:^/}
                  help :obj
               ] [
                  print {"^/}
                  help obj
               ] ; either object?
            ] ; either function?
         ] ; use
         exit
      ] ; if path?

      if object? :word [
         use [
            wrd    ; word in object
            wrdv   ; value of said word
            hlp    ; functions help string
            format ; formatting function
            line   ; output line
            line2  ; output line (type part)
         ] [
            format: func [s][
               replace/all either 30 > length? s [s][
                  join copy/part s 30 " ..."
               ] "^/" "^^/"
            ]

            print "object with fields:"
            foreach wrd next first :word [
               line: copy "              "
               line2: copy "          "
               change line wrd
               ; check if the word has a value
               either value? in :word wrd [
                  wrdv: get in :word wrd
                  change line2 rejoin ["(" type? :wrdv ")" ] 
                  either any-function? :wrdv [
                     print rejoin [tab line " " line2 " " 
                            either string? hlp: pick pick :wrdv 3 1 [
                           format hlp]["..."]]
                  ] [
                     print rejoin [
                        tab line " " line2 " "
                        either object? wrdv ["..."][
                           format mold wrdv
                        ]
                     ]
                  ] ; either any ...
                  true
               ] [
                  change line2 "()"
                  print rejoin [ tab line " " line2 " Value is not set"]
               ] ; if value? 
            ] ; foreach
            exit
         ] ; use
      ] ; if object? get :word

   ] ; if not word?

   ; /\ /\ /\ end changes by iho


    value: get word
    if not any-function? :value [
        print [uppercase mold word "is" type-name :value "of value:" mold :value] 
        exit
    ] 

   args: third :value
   prin "USAGE:^/^-"
   if not op? :value [prin append uppercase mold word " "]
   while [not tail? args] [
      item: first args
      if :item = /local [break]
      if any [all [any-word? :item not set-word? :item] refinement? :item] [
         prin append mold :item " "
         if op? :value [prin append uppercase mold word " " value: none]
      ]
      args: next args
   ]
   print ""
   args: head args
   value: get word
   print "^/DESCRIPTION:"
   either string? pick args 1 [
      print [tab first args newline tab uppercase mold word "is" type-name :value "value."]
      args: next args
   ] [
      print "^-(undocumented)"
   ]
   if block? pick args 1 [
      attrs: first args
      args: next args
   ]
   if tail? args [exit]
   while [not tail? args] [
      item: first args
      args: next args
      if :item = /local [break]
      either not refinement? :item [
         all [set-word? :item :item = first [return:] block? first args rtype: first args]
         if none? refmode [
            print "^/ARGUMENTS:"
            refmode: 'args
         ]
      ] [
         if refmode <> 'refs [
            print "^/REFINEMENTS:"
            refmode: 'refs
         ]
      ]
      either refinement? :item [
         prin [tab mold item]
         if string? pick args 1 [prin [" --" first args] args: next args]
         print ""
      ] [
         if all [any-word? :item not set-word? :item] [
            if refmode = 'refs [prin tab]
            prin [tab :item "-- "]
            types: if block? pick args 1 [args: next args first back args]
            if string? pick args 1 [prin [first args ""] args: next args]
            if not types [types: 'any]
            prin rejoin ["(Type: " types ")"]
            print ""
         ]
      ]
   ]
   if rtype [print ["^/RETURNS:^/^-" rtype]]
   if attrs [
      print "^/(SPECIAL ATTRIBUTES)"
      while [not tail? attrs] [
         value: first attrs
         attrs: next attrs
         if any-word? value [
            prin [tab value]
            if string? pick attrs 1 [
               prin [" -- " first attrs]
               attrs: next attrs
            ]
            print ""
         ]
      ]
   ]
   exit
]

;
; Patches by others
;


; bo@rebol.com
replace: func [
    {Replaces the search value with the replace value within the target series. *PATCHED*} 
    target [series!] "Series that is being modified." 
    search "Value to be replaced." 
    replace "Value to replace with." 
    /all "Replace all occurrences." 
    /case "Case-sensitive replacement."
    /local save-target len
][
    save-target: target 
    if (any-string? target) and ((not any-string? :search) or (tag? :search)) [search: form :search] 
    len: either any [any-string? target any-block? :search] [length? :search] [1] 
    while [target: either case [find/case target :search][find target :search]] [
        target: change/part target :replace len 
        if not all [break]
    ] 
    save-target
]


;
; history
;

; patched to save history in advance
; bohdan lechnowsky <bo@rebol.com>, iho
; (the function for reloading history is in user.r )
q: func ["Saves console history to %history.r and quits *PATCHED*"] [
   ; save-history is in Definitions.r
   save-history to-file rejoin [ system/options/home "Work/" system/product "/rebol-history.r" ]
   quit
]

;
; And I am once again just using Andrews code ...
;

comment [
   REBOL [
      Title: "Patch"
      Date: 3/December/1999
      Name: 'Patch
      Version: 2.0.0
      File: %Patch.r
      Home: http://members.xoom.com/AndrewMartin/
      Author: "Andrew Martin"
      Owner: "Andrew Martin"
      Rights: "Copyright © 1999, Andrew Martin."
      Needs: 2.2.0
      Tabs: 4
      Usage: { 
                Place: 
                                do %Patch.r 
                        in your %user.r file, 
                        to have this done at each startup. 
                }
      Purpose: { 
                Patches the http scheme open function 
                to provide a better choice for User-Agent. 
                }
      History: [
         1.0.1 [1/Dec/1999 {Creation!} {Andrew}]
         1.1.0 [3/Dec/1999 {Got 'bind-ing correct.} {Andrew}]
         1.1.1 [3/Dec/1999 {User alteration of HTTP User Agent.} {Andrew}]
         2.0.0 [3/Dec/1999 {Implemented generic patch.} {Andrew}]
      ]
      Language: 'English
      Email: Al.Bri@xtra.co.nz
      Site: http://members.xoom.com/AndrewMartin/
      Category: 'general
      Charset: 'ANSI
      Example: {}
   ]
]
Http_User_Agent: rejoin ["Mozilla" "/" "4.0"
   " (Compatible; REBOL " system/version ")"]

Patches: reduce [
   system/schemes/http/handler 'open
   {User-Agent: reform ["REBOL" system/version]}
   join {User-Agent: } to-string 'Http_User_Agent
]

Patch: function [Patches [block!]] [Word_Reference Body_Text] [
   foreach [Object Word Original Replacement] Patches [
      Word_Reference: in Object Word
      Body_Text: mold second get Word_Reference
      replace Body_Text Original Replacement
      set Word_Reference func
      first get Word_Reference
      bind to-block load Body_Text Word_Reference
   ]
]

Patch Patches



;
; other small Patches
;

Script: func [
   "Returns the script source code for a word. *PATCHED*"
   Word [word!]
][
   either not value? Word [
      join {unset '} Word
   ][
      join "" [
         Word ": "
         either any [
            native? get Word
            op? get Word
            action? get Word
         ][
            join "native" mold third get Word
         ][
            either not error? try [get get Word] [
               join {'} get Word   ; show a literal word.
            ][
               mold get Word
            ]
         ]
      ]
   ]
]

Redefine source SourceOriginal

Source: func [
   "Prints the script source code for a word. *PATCHED*"
   'Word [word!]
][
   print Script Word
]

comment [
   Redefine switch SwitchOriginal

   Switch: func [
      "Selects a choice and evaluates what follows it."
      Value [any-type!] "Value to search for."
      Cases [block!] "Case block to search in."
      /Default Case [block!] "Default case block."
   ][
      either found? Value: select reduce Cases Value [
         do Value
      ][
         either Default [
            do Case
         ][
            none
         ]
      ]
   ]
]

; End.