Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Help update red scripts collection list
Red [
title: "Update red scripts collection list"
file: %add-script.red
author: "Marco Antoniazzi"
license: "Do with this code whatever you want, giving credit to me is NOT required"
email: [luce80 AT alice DOT it]
date: 01-07-2018
version: 1.0.1
Purpose: "Help update red scripts collection list"
Needs: 'View
]
requesters: context [
; ======
; Author: Gregg Irwin. Taken from https://gist.github.com/greggirwin/9cd640ca42bdfd56c5ff4432c4765d2c
; ======
; Window flags: modal resize no-title no-border no-min no-max no-buttons popup
; Native OS: Dir, File, Font
; In this lib: Notify, Alert, Confirm, Prompt, Color, Date(TBD)
;---------------------------------------------------------------------------
; General warning: Yellow in black triangle with exclamation 239.202.64
; Information: i
; Prohibition: Red stop/slash-circle (ul to lr) 177.34.54
; Mandatory Action: Exclamation in blue circle 30.81.133
iso-yellow: 239.202.64
iso-red: 177.34.54
iso-blue: 30.81.133
;iso-font-40: make font! [style: 'bold size: 40 name: "Times New Roman"]
iso-font-40: make font! [style: 'bold size: 40 name: "Symbol"]
iso-font-40i: make font! [style: [bold italic] size: 40 name: "Times New Roman"]
;iso-font-32: make font! [style: 'bold size: 32 name: "Symbol"]
iso-font-26: make font! [style: 'bold size: 26 name: "Symbol"]
svvs: system/view/vid/styles
svvs/iso-info: [
template: [
type: 'base size: 48x48 color: none
draw: [font iso-font-40i pen iso-blue fill-pen iso-blue circle 24x24 23 pen white text 7x-7 "i"]
]
]
svvs/iso-question: [
template: [
type: 'base size: 48x48 color: none
draw: [font iso-font-40 pen iso-blue fill-pen iso-blue circle 24x24 23 pen white text 3x-11 "?"]
]
]
svvs/iso-warning: [
template: [
type: 'base size: 48x48 color: none
draw: [font iso-font-26 pen black fill-pen iso-yellow line-width 4 line-join round polygon 24x4 46x44 2x44 text 13x5 "!"]
]
]
svvs/iso-action-required: [
template: [
type: 'base size: 48x48 color: none
draw: [font iso-font-40 pen iso-blue fill-pen iso-blue circle 24x24 23 pen white text 7x-12 "!"]
]
]
svvs/iso-prohibit: [
template: [
type: 'base size: 48x48 color: none
draw: [pen iso-red fill-pen white line-width 5 circle 24x24 21 line-width 4 line 8x8 40x40]
]
]
;view [iso-info iso-warning iso-action-required iso-prohibit]
;---------------------------------------------------------------------------
svvs/timer: [
default-actor: on-time
template: [
type: 'base size: 0x0 color: none
]
]
std-dialog-actors: object [
res: none
on-key: func [face event] [
;print [mold event/key mold event/flags]
;!! If control is down, keys are always uppercase chars, including
; the caret, so we don't really need to check for 'control in
; event/flags if that is by design. Nice for char-key mapping.
switch event/key [
#"^M" [res: true unview] ; enter
#"^[" [res: none unview] ; escape
#"^O" #"^Y" [if find event/flags 'control [res: true unview]]
#"^C" [if find event/flags 'control [res: none unview]]
#"^N" [if find event/flags 'control [res: false unview]]
]
]
]
std-dialog-opts: compose [
flags: [modal no-min no-max]
actors: (std-dialog-actors)
]
;---------------------------------------------------------------------------
; To set the title for a dialog, use [title "xxx"] in the layout, or options/text.
; To set the offset for a dialog, use options/offset.
show-dialog: function [
spec [block! object!]
/options opts [block!] "[offset: flags: actors: menu: parent: text:]"
/timeout time [time!] "Hide after timeout; only block specs supported"
/with init [block! none!] "Code to run after layout, before showing; e.g., to center face"
][
;if time [spec: add-dialog-timeout spec time]
if block? spec [
if time [spec: append copy spec reduce ['timer 'rate time [unview]]]
spec: layout spec
]
face: :spec ; let them use 'face in init block
if init [do bind/copy init 'face]
view/options spec make std-dialog-opts any [opts []]
spec
]
; alert [ok] confirm [ok cancel] prompt [text box]
set 'alert function [
"Display a dialog with a short message, until the user closes it"
msg
;/options opts [block!] "[offset: flags: actors: menu: parent: text:]"
/style sty [word!] "Include standard image and title: [info warn stop action]"
/over ctr [object!] "Center over this face"
/offset pos [pair!] "Top-left offset of window"
/local img txt
][
set [img txt] switch/default sty [
info [[iso-info "Information"]]
warn [[iso-warning "Warning"]]
stop [[iso-prohibit "Stop!"]]
action [[iso-action-required "Action required"]]
][[iso-warning "Warning"]] ; paren == unset, for no image
spec: compose [
title (txt)
across (get/any 'img) pad 10x0 text font-size 12 350x70 (form msg) return
pad 300x0 button "OK" [res: true unview]
]
;opts: append copy std-dialog-opts opts ;any [opts [flags: [modal no-min no-max]]]
opts: copy/deep std-dialog-opts
if pair? pos [append opts compose [offset: (pos)]]
if ctr [init: [center-face/with face ctr]] ; 'face refers to the dialog
show-dialog/options/with spec opts init
res
]
; added function by luce80
set 'flash function [
"Flashes a message to the user and continues."
msg
/with ctr [object!] "Center over this face"
/offset pos [pair!] "Top-left offset of window"
/timeout time [time!] "Hide after timeout; only block specs supported"
/local spec opts
][
spec: compose [
title "Information"
across iso-info pad 10x0 text font-size 12 350x70 (form msg) return
]
opts: compose [
flags: [no-min no-max]
actors: (std-dialog-actors)
]
if pair? pos [append opts compose [offset: (pos)]]
if time [spec: append spec reduce ['timer 'rate time [unview]]]
spec: layout spec
; FIXME: if time [append spec/pane make face [...]]
if ctr [center-face/with spec ctr]
face: :spec ; let them use 'face in init block
view/no-wait/options spec make std-dialog-opts any [opts []]
spec
]
]
get-details: function [
link
][
curl:
field-curl/text
if any [none? curl not exists? to-red-file form curl] [alert "cURL is required to fetch informations from internet"]
;"E:\Programmi\Prog\Git\mingw64\bin\curl.exe"
if not url? link [alert "Please provide a URL first" exit]
out: ""
author: ""
script: ""
descr: ""
id: ""
url: form link
f1: flash/timeout "Fetching informations..." 00:00:02
call/wait/output rejoin [curl " " url] out: copy ""
unview/only f1
space: charset " ^-^/"
case [
find url "https://gist.github" [
parse url [thru {https://gist.github.com/} copy author to {/} {/} copy id to end]
gist: probe rejoin [{<a href="/} author {/} id {">}]
parse out [thru gist copy script to {</a>}]
parse out [thru {itemprop="about">} copy descr to {<}]
]
find url "https://github.com" [
parse url [thru {https://github.com/} copy author to {/} {/} copy script to end]
parse out [thru {itemprop="about">} copy descr to {<}]
]
find url "https://gitlab.com" [
parse url [thru {https://gitlab.com/} copy author to {/} {/} copy script to end]
parse out [thru {<div class="project-home-desc">} any space opt {<p dir="auto">} copy descr to {<}]
]
]
field-auth/data: author
field-script/data: script
field-link/data: link
field-descr/text: trim/lines descr
;field-tags:
]
update_wiki: function [] [
if error? try [
if any [
equal? trim field-auth/text ""
equal? trim field-script/text ""
equal? trim field-link/text ""
]
[
field-auth/color: red + 150
field-script/color: red + 150
field-link/color: red + 150
alert "Please fill at least ALL highlighted fields"
field-auth/color: white ; FIXME: assuming background of fields is white
field-script/color: white
field-link/color: white
set-focus field-auth
exit
]
page: head area-source/text
if "" = page [alert "Please paste wiki page source markdown text in the text area"]
author: trim field-auth/text
script: trim field-script/text
data: rejoin ["^-* [" script "](" field-link/text ") - " field-descr/text "^/^/^-^-tags: " field-tags/text "^/"]
letter: uppercase first author
if letter > #"Z" [cause-error "Problem with author first letter"]
start: none
new-start: none
parse page [thru ["* " author " "] thru "^/" start:]
if none? start [
; insert new author and data sorted
parse page [thru ["## " letter] "^/" start:]
authors-rule: [ new-start: "* " copy curr-author to " " [[to ["^/* " | "^/## "] "^/"] | [to "^/^/^/[0](#0)"]](
if author < curr-author [
insert new-start rejoin ["* " author " - ^/" data]
exit
]
)]
parse start [some authors-rule new-start: (insert new-start rejoin ["* " author " - ^/" data] exit)]
]
; insert new data sorted
space: charset " ^-^/"
data-rule: [new-start: some space "* [" copy curr-script to "]" thru "tags:" thru "^/" (
if script < curr-script [
insert new-start data
exit
]
)]
parse start [some data-rule (insert new-start data exit)]
][alert "Unable to update wiki page, please do it manually."]
]
view layout [
title "Help update red scripts collection"
do [sp: 4x4] origin sp space sp
style label: text 100 ; FIXME: para [origin: 0x3] use this when para/origin will be implemented
style field: field 600 ""
label "cURL.exe" field-curl: field 534 button "..." [field-curl/text: to-local-file request-file/title "Select cURL exe"] return
below
text bold {1) Paste wiki page source markdown text in the text area below}
area-source: area 800x250
text bold {2) Paste script's link (currently: gist, github and gitlab) in the field below and press "Fill fields" button or ...}
Across
label "URL" field-url: field 534
button "Fill fields" [get-details field-url/data] return
text bold "3) ...Fill the fields and ..." 200 return
label "Author" field-auth: field return
label "File name" field-script: field return
label "Link" field-link: field return
label "Description" field-descr: field return
label "Tags" field-tags: field return
label bold "4)"
button "...update wiki source" [update_wiki] text bold " and check that it's all ok"
return
label bold {5) Finally} button "copy area text to clipboard" [write-clipboard area-source/text] text bold 30 " and "
button {browse to https://github.com/red/red/wiki/Scripts-collection/_edit} [browse https://github.com/red/red/wiki/Scripts-collection/_edit]
return
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment