fhp
Priskribo de la ĉi-paĝa enhavo
Ilaro verkita en Fortho por krei HTML-ajn dokumentojn.
Etikedoj:
fhp estas programo verkita por krei XHTML-paĝojn. Fine ĝi iĝis suba ilaro sur kiun mi verkis alian programon por krei kompletajn retpaĝarojn, ForthCMS, kiu ankore nepublikigitas.
Dum jaroj mi programadis kaj uzis na fhp per Forth 5mx. Poste fine, post ŝanĝetoj, mi ekuzis ĝin en Gforth.
Fontkodo
fhp.fs
\ fhp.fs
cr .( fhp )
\ Copyright (C) 2004,2005,2006,2007,2008,2009,2010,2012 Marcos Cruz (programandala.net)
\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp).
\ This is the main file: it does some general configuration
\ and loads all fhp modules.
\ fhp is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2 of the License, or
\ (at your option) any later version.
\
\ fhp is distributed in the hope that it will be useful, but
\ WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\ General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with fhp; if not, see <http://gnu.org/licenses>.
\ fhp is written in the Forth language
\ with Gforth (http://gnu.org/software/gforth/).
\ .............................................................
\ History
\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2004-12: This project started. Every fhp module has a a detailed change
\ history in its source.
\
\ 2008-01-20: The word LOCAL-SLASH is not a constant any more but a value, to
\ make it easier to configure; now it changes depending on the Forth system.
\
\ 2010-10-07: First support for Simplilo's format output: 'simplilo?' flag.
\
\ 2012-07-31: First support for Fendo's format output: 'fendo?' flag.
\ .............................................................
\ Init
[undefined] from_forth5mx [IF] S" from_forth5mx.fs" INCLUDED [THEN]
\ [undefined] fstr [IF] S" fstr.fs" INCLUDED [THEN] \ strings toolkit needed
[undefined] ftrac [IF]
S" ftrac/ftrac.fs" INCLUDED \ char translation tool needed
S" ftrac/ftrac-utf8es.fs" INCLUDED \ translation table for HTML entities
[THEN]
\ [undefined] ftra [IF]
\ S" ftra/ftra.fs" INCLUDED \ string translation tool needed when Simplilo's format output is active
\ S" ftra/ftra-simplilo.fs" INCLUDED \ translation table for HTML entities
\ [THEN]
[undefined] fjpg [IF] S" fjpg.fs" INCLUDED [THEN] \ jpeg tookit needed
[undefined] n>str [IF] S" n2str.fs" INCLUDED [THEN] \ number to string conversion tool
\ S" ffl/rgx.fs" INCLUDED \ Regular expressions library of the File Foundation Library (needed when Simplilo's format output is active) deprecated!!!
\ .............................................................
\ Configuration
false VALUE simplilo? \ flag: Do create Simplilo's WikiCreole pages instead of HTML pages?
\ (implemented in 2010-10 in order to export several websites from fhp+ForthCMS to Simplilo).
false VALUE fendo? \ flag: Do use the new file names (planned for Simplilo) in order to make it easier to migrate to Fendo (the projected Forth web engine that will substitute fhp+ForthCMS)?
\ (implemented in 2012-07-31).
CHAR \ VALUE local-slash \ used when joining local paths
gforth? [IF] CHAR / TO local-slash [THEN] \ the word gforth? is defined in the file from_forth5mx.fs
defer trac-default
' trac-utf8es is trac-default
\ .............................................................
\ Load all fhp modules
S" fhp-core.fs" INCLUDED \ core
S" fhp-paths.fs" INCLUDED \ local and web paths tools
\ 2007-02-07:
\ The fhp-paths module must be loaded before the fhp-tags module.
\ Otherwise +extension word doesn't work in multilingual mode. I don't understand why.
\ The bug arised after moving the +extension word into the fhp-paths module.
\ It must be caused by the definition order of certain words.
S" fhp-tags.fs" INCLUDED \ XHTML tags
S" fhp-ml.fs" INCLUDED \ multilingual core tools
S" fhp-img.fs" INCLUDED \ image tags
S" fhp-date.fs" INCLUDED \ date and time tools
\ .............................................................
\ Misc
: fhp-link ( -- )
\ Create a promotional fhp link.
xhtml11
IF S" <abbr xml:lang='en' title='Forth HTML Preprocessor'>fhp</abbr>"
ELSE S" <abbr xml:lang='en' lang='en' title='Forth HTML Preprocessor'>fhp</abbr>"
THEN
\ S" hreflang='es' title='Página de fhp'" S" http://programandala.net/es.programa.fhp"
\ S" hreflang='eo' title='fhp-retpaĝo'" S" http://programandala.net/eo.programo.fhp"
S" hreflang='en' title='fhp web page'" S" http://programandala.net/en.program.fhp"
{a/a}
;
.( fhp ok! )
fhp-paths.fs
CR .( fhp-paths )
\ Copyright (C) 2006,2007,2010 Marcos Cruz (programandala.net)
\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp).
\ This module provides the paths, filenames and file tools.
\ fhp is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2 of the License, or
\ (at your option) any later version.
\
\ fhp is distributed in the hope that it will be useful, but
\ WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\ General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with fhp; if not, see <http://gnu.org/licenses>.
\ fhp is written in the Forth language
\ with Gforth (http://gnu.org/software/gforth/).
\ .............................................................
\ History (in reversed order)
\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2010-10-07: First support for Simplilo's format output.
\
\ 2007-04-08: Used the new constant LOCAL-SLASH . It is initialized in
\ the fhp loader.
\
\ 2007-01-22: Improved with +ARC-DISK-PATH and +ARC-URL-PATH .
\
\ 2006-08-08: Created with code written for the program alinome-bici.
\ .............................................................
\ Init
MARKER fhp-paths
\ .............................................................
\ File extensions
: +".html" ( c-addr1 u1 -- c-addr2 u2 )
\ 2006-03-14
\ 2007-02-07 Moved from the module fhp-ml.
\ 2010-10-07 Support for Simplilo's format.
simplilo? 0= IF
S" .html" str+
THEN
;
defer +extension \ 2007-02-07 Moved from the module fhp-ml and defered, in order to make it accessible also in monolingual webs.
' +".html" is +extension
\ .............................................................
\ Labels
: (+label) ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ Join a file name and a label.
\ c-addr1 u1 = label
\ c-addr2 u2 = file name with extension
\ 2007-04-07
S" #" str+ 2SWAP str+
;
: +label ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ Joins a file name and a label
\ c-addr1 u1 = file name with extension
\ c-addr2 u2 = label
\ 2007-04-06
2SWAP (+label)
;
: file+label ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ Join a file name and a label.
\ c-addr1 u1 = file name without extension
\ c-addr2 u2 = label
\ 2007-04-04 First version
\ 2SWAP +extension (+label)
\ 2007-05-07 Added conditions, to make the word more general
\ Now it is used by the calculated field >PAGE-FILE#LABEL .
2SWAP DUP IF +extension THEN
2 PICK IF (+label) ELSE 2SWAP 2DROP THEN
;
\ .............................................................
\ Paths
\ Image directories:
svariable img-dir \ image base directory under html-path
svariable img-subdir 0 img-subdir C! \ optional img subdirectory under img-dir
svariable img-path \ image local directory while building the site
\ Archive directories for downloadable files:
svariable arc-dir \ archive base directory under html-path
svariable arc-subdir 0 arc-subdir C! \ optional archive subdirectory under img-dir
svariable arc-path \ archive local directory while building the site
: (cpath+) ( c-addr1 u1 c-addr2 u2 b -- c-addr4 u4 )
\ Join two file paths (with a join sign between them, if it is not already at the join).
\ c-addr1 u1 = left string
\ c-addr2 u2 = right string
\ b = join char (generally a slash or a back slash)
\ 2007-06-03 Factored from PATH+ .
\ 2008-01-19 Renamed (formerly (PATH+) ) because of the gforth word PATH+ .
>R
OVER C@ >R \ first char of the right string
2SWAP 2DUP 1- + C@ \ last char of the left string
R> R@ <> SWAP R@ <> AND \ are both chars different than the join char?
IF R> b>str str+ 2SWAP str+
ELSE R> DROP 2SWAP str+
THEN
;
: cpath+ ( c-addr1 u1 c-addr2 u2 b -- c-addr4 u4 )
\ Join two file paths (with a join char between them, if it is not already at the join)
\ if no string is empty.
\ c-addr1 u1 = left string
\ c-addr2 u2 = right string
\ b = join char (generally a slash or a back slash)
\ 2006-07-02
\ 2007-06-03 Improved. Now it controls also if the first string is empty.
\ That fixes a bug detected when w3c icons files joined their empty subdir:
\ the result was a file with a slash at the start, what made the final result had two slashes.
\ That made Forth 5mx (not WinForth) fail when trying to open the local image file to get its measures.
\ 2008-01-19 Renamed (formerly PATH+ ) because of the gforth word PATH+ .
OVER 0=
IF \ the second string is empty
DROP 2DROP \ return the first string
ELSE
>R 2SWAP DUP >R 2SWAP R> 0= R> SWAP
IF \ the first string is empty
DROP 2SWAP 2DROP \ return the second string
ELSE
(cpath+)
THEN
THEN
;
: disk-path+ ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ Join two parts of a local path.
\ 2006-07-02
local-slash cpath+
;
: url-path+ ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ Join two parts of a web path.
\ 2006-07-02
[CHAR] / cpath+
;
: />\ ( c-addr u -- c-addr u )
\ Change "slashes" into "back slashes".
2DUP 0 DO
DUP I + C@ [CHAR] / =
IF DUP I + [CHAR] \ SWAP C! THEN
LOOP DROP
;
: \>/ ( c-addr u -- c-addr u )
\ Change "back slashes" into "slashes".
2DUP 0 DO
DUP I + C@ [CHAR] \ =
IF DUP I + [CHAR] / SWAP C! THEN
LOOP DROP
;
: +img-disk-path ( c-addr1 u1 -- c-addr2 u2 )
\ Add the whole local path to an image file.
\ c-addr1 u1 = filename without arc-dir and arc-subdir
\ c-addr2 u2 = whole local path to the archive
\ 2006-07-12
\ 2006-08-10 Modified to use IMG-SUBDIR ; renamed: former name was WHOLE-IMG-PATH .
\ 2007-03-21 Bug fixed, difficult to find: the word />\ was at the beginning, and that modified the original parameter in the stack,
\ what made problems with -URL-PATH . Now the slash translation is made at the end, on the result string stored iun the string buffer.
\ 2008-01-20 Modified. The slash conversion is not done when the OS class is Unix.
img-path COUNT
img-subdir COUNT disk-path+
2SWAP disk-path+
[ unix? 0= ] [IF] \ the word unix? is defined in the file from_5mx.f
/>\ \ translate slashes that could be in the original parameter into back slahses
[THEN]
;
: +img-url-path ( c-addr1 u1 -- c-addr2 u2 )
\ Add the whole web path to an image file.
\ c-addr1 u1 = filename without arc-dir and arc-subdir
\ c-addr2 u2 = whole web path to the archive
\ 2006-08-10
\>/ \ because of a possible local directory included
img-dir COUNT img-subdir COUNT url-path+
2SWAP url-path+
;
: +arc-disk-path ( c-addr1 u1 -- c-addr2 u2 )
\ Add the local path to a downloadable file.
\ c-addr1 u1 = filename without arc-dir and arc-subdir
\ c-addr2 u2 = whole web path to the archive
\ 2007-01-22
\ 2008-01-20 Modified. The slash conversion is not done when the OS class is Unix.
[ unix? 0= ] [IF] \ the word unix? is defined in the file from_5mx.f
/>\ \ because of a possible local directory included
[THEN]
arc-path COUNT arc-subdir COUNT disk-path+
2SWAP disk-path+
;
: +arc-url-path ( c-addr1 u1 -- c-addr2 u2 )
\ Add the whole web path to a downloadable file.
\ c-addr1 u1 = filename without arc-dir and arc-subdir
\ c-addr2 u2 = whole web path to the archive
\ 2007-01-22
\>/ \ because of a possible local directory included
arc-dir COUNT arc-subdir COUNT url-path+
2SWAP url-path+
;
\ .............................................................
\ Extract from paths
: only-one ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 | c-addr2 u2 )
\ If the top string is not empty, keep it. Otherwise drop it.
\ 2007-01-16
\ 2007-03-21 Moved here from the fhp-links module.
DUP IF 2SWAP THEN 2DROP
;
: -extension ( c-addr1 u1 -- c-addr2 u2 )
\ Take off the file name extension.
\ c-addr1 u1 = file name with extensions
\ c-addr2 u2 = file name without extensions
\ 2007-02-24 Migrated from the aplication alinome-bici
\ [CHAR] . /char-in-str 2SWAP 2DROP
\ 2007-03-21 Bug fixed. ONLY-ONE used instead of 2SWAP and 2DROP .
[CHAR] . /last-char-in-str only-one
;
: -url-path ( c-addr1 u1 -- c-addr2 u2 )
\ Take off the URL-like path (that is, with slashes).
\ 2007-02-24
\ c-addr1 u1 = file name with URL-like path
\ c-addr2 u2 = file name without path
[CHAR] / /last-char-in-str 2DROP
;
: path-only ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = URL
\ c-addr2 u2 = URL without parameteres
\ 2007-01-16
\ 2007-04-05 Moved here from the upper layer, from the forthCMS-links module
[CHAR] ? /char-in-str only-one
;
: domain-only ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = URL
\ c-addr2 u2 = domain
\ 2007-01-16
\ 2007-04-05 Moved here from the upper layer, from the forthCMS-links module
[CHAR] / /char-in-str only-one
;
: (.fhp-path) ( c-addr1 u1 c-addr2 u2 -- )
\ Show a path: name, description and content.
\ c-addr1 u1 = name of the string variable
\ c-addr2 u2 = description
\ 2007-12-09
CR TYPE [CHAR] : EMIT
2DUP CR TYPE ." = "
EVALUATE COUNT TYPE
;
: .fhp-paths ( -- )
\ Show the current paths.
\ 2007-12-08
CR CR ." Current fhp paths:" CR
S" html-path"
S" Main path for the HTML pages"
(.fhp-path)
CR CR ." Directories for images:" CR
S" img-dir"
S" Image base directory under html-path "
(.fhp-path)
S" img-subdir"
S" Optional image subdirectory under img-dir "
(.fhp-path)
S" img-path"
S" Image local directory while building the site (used to read the image properties)"
(.fhp-path)
CR CR ." Directories for files (downloadable, media...):" CR
S" arc-dir"
S" Archive base directory under html-path "
(.fhp-path)
S" arc-subdir"
S" Optional archive subdirectory under arc-dir "
(.fhp-path)
S" arc-path"
S" Archive local directory while building the site (used to read the file properties)"
(.fhp-path)
CR CR
;
.( fhp-paths ok!)
fhp-tags.fs
CR .( fhp-tags )
\ Copyright (C) 2006,2007,2008,2009,2010 Marcos Cruz (programandala.net)
\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp).
\ This module provides the basic HTML tags.
\ fhp is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2 of the License, or
\ (at your option) any later version.
\
\ fhp is distributed in the hope that it will be useful, but
\ WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\ General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with fhp; if not, see <http://gnu.org/licenses>.
\ fhp is written in the Forth language
\ with Gforth (http://gnu.org/software/gforth/).
\ .............................................................
\ History (in reversed order)
\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2010-10-07: First support for Simplilo's format output.
\
\ 2009-10-21: Alias created: ' {tag/tag} alias {tag/}
\
\ 2009-07-30: Added {/TABLE} , {TBODY} and {/TBODY}
\
\ 2009-04-15: Added >REL-ATTRIBUTE and +REL-ATTRIBUTE
\
\ 2009-04-04: Added {div}
\
\ 2008-08-23: Added: {_} {.} {,} {:} {;} {'}
\
\ 2008-04-20: Added {/OBJECT}
\
\ 2008-04-10: Added: {pre} {/pre} {pre/pre} .
\
\ 2007-08-22: Added {/SCRIPT}
\
\ 2007-04-11: >LANG-ATTRIBUTE improved.
\
\ 2007-04-08: Hidden bug found and fixed in the second version of
\ UNTAG .
\
\ 2007-04-06: Links tags are renamed and moved here from the fhp-links
\ module. Now they will be basic tags. The more elaborated words to
\ build links will be in the the upper forthCMS level.
\
\ 2007-04-05: Added {BODY} , {/BODY} , {HTML} and {/HTML} . Added
\ {LINK} and {META} . All other meta-data and meta-link tags are
\ moved to the forthCMS-tags module.
\
\ 2007-04-04: Added {HEAD} and {/HEAD} .
\
\ 2007-02-07: Adedd LOCAL-METALINK and HTTP-METALINK .
\
\ 2007-01-31: Added {/SPAN} and {SPAN/SPAN} .
\
\ 2007-21-22: Added >TYPE-ATTRIBUTE and +TYPE-ATTRIBUTE Added &NBSP;
\
\ 2007-01-04: New words {TR} {/TR} {TD} {/TD} and {TD/TD} .
\
\ 2006-12-04: New words {KBD} {/KBD} and {KBD/KBD} .
\
\ 2006-11-22: New word TITLE and related.
\
\ 2006-10-05: Added {/A} , formerly defined in the module fhp-links.
\
\ 2006-09-14: Added {/SPAN}
\
\ 2006-09-1 Added {OL} an {/OL} .
\
\ 2006-09-09: Added {EM} {/EM} and {EM/EM} .
\
\ 2006-09-05: New fixed, faster and improved version of UNTAG .
\
\ 2006-09-02: New words >LANG-ATTRIBUTE and +LANG-ATTRIBUTE .
\ >SPAN+LANG modified; also renamed to >SPAN-LANG , and so its child
\ words.
\
\ 2006-09-01: New word UNTAG and related.
\
\ 2006-08-24: New words KEYWORDS and COMMON-KEYWORDS .
\
\ 2006-06-27: New word >SPAN+LANG and related.
\
\ 2006-06-25: Spell mistake fixed in accesskey attribute words.
\
\ 2006-06-26: New <strong> tag words.
\
\ 2006-06-24: New words for tags <h4> to <h6>, {P/P} and {TITLE/TITLE}
\ .
\
\ 2006-06-04: Word ANCHOR moved to the new module fhp-links.
\
\ 2006-05-27: Word ANCHOR taken from my application alinome-prg.
\
\ 2006-05-26: Module forked from fhp. Words that make HTML tags are
\ taken from my application alinome-prg.
\ .............................................................
\ Init
MARKER fhp-tags
\ .............................................................
\ Pseudo tags
\ Synonyms of some core words:
' space>html alias {_}
' space>html alias {space}
' dot>html alias {.}
' comma>html alias {,}
' colon>html alias {:}
' semicolon>html alias {;}
' tick>html alias {'}
' quote>html alias {"}
\ .............................................................
\ HTML tags
simplilo? [IF]
: {/a} S" ]]" >>html ;
: {blockquote} cr>html {"} {"} cr>html ;
: {/blockquote} {blockquote} ;
: {body} ;
: {/body} ;
: {br} S" \\" >>html ;
: {div} S" <<html div />>" >html ;
: {/div} S" <<div/>>" >html ;
: {dd} space>html ;
: {/dd} ;
: {dd/dd} ( c-addr u -- ) {dd} >html {/dd} ;
' {dd/dd} alias {dd/}
: {dl} cr>html ;
: {/dl} cr>html ;
: {dt} S" * **" >html ;
: {/dt} S" **" >>html ;
: {dt/dt} ( c-addr u -- ) {dt} >>html {/dt} ;
' {dt/dt} alias {dt/}
: {em} S" //" >>html ;
: {/em} {em} ;
: {em/em} ( c-addr u -- ) {em} >>html {/em} ;
' {em/em} alias {em/}
: {head} ;
: {/head} cr>html cr>html ;
: {h1} cr>html S" =" >html ;
: {/h1} cr>html ;
: {h1/h1} ( c-addr u -- ) {h1} >>html {/h1} ;
' {h1/h1} alias {h1/}
: {h2} cr>html S" ==" >html ;
: {/h2} cr>html ;
: {h2/h2} ( c-addr u -- ) {h2} >>html {/h2} ;
' {h2/h2} alias {h2/}
: {h3} cr>html S" ===" >html ;
: {/h3} cr>html ;
: {h3/h3} ( c-addr u -- ) {h3} >>html {/h3} ;
' {h3/h3} alias {h3/}
: {h4} cr>html S" ====" >html ;
: {/h4} cr>html ;
: {h4/h4} ( c-addr u -- ) {h4} >>html {/h4} ;
' {h4/h4} alias {h4/}
: {h5} cr>html S" =====" >html ;
: {/h5} cr>html ;
: {h5/h5} ( c-addr u -- ) {h5} >>html {/h5} ;
' {h5/h5} alias {h5/}
: {h6} cr>html S" ======" >html ;
: {/h6} cr>html ;
: {h6/h6} ( c-addr u -- ) {h6} >>html {/h6} ;
' {h6/h6} alias {h6/}
: {hr} S" ----" >html cr>html ;
: {html} ;
: {/html} ;
: {kbd} S" <<kbd " >>html ;
: {/kbd} S" />>" >>html ;
: {kbd/kbd} ( c-addr u -- ) {kbd} >>html {/kbd} ;
' {kbd/kbd} alias {kbd/}
: {li} S" * " >html ;
: {/li} ;
: {li/li} ( c-addr u -- ) {li} >>html {/li} ;
' {li/li} alias {li/}
: {/object} S" <<object/>>" >html ;
: {ol} S" {* <ol> *}" >html ;
: {/ol} cr>html cr>html ;
: {p} cr>html cr>html ;
: {/p} {p} ;
: {p/p} ( c-addr u -- ) {p} >>html {/p} ;
' {p/p} alias {p/}
: {pre} S" {{{" >html cr>html ;
: {/pre} S" }}}" >html cr>html ;
: {pre/pre} ( c-addr u -- ) {pre} >html {/pre} ;
' {pre/pre} alias {pre/}
: {/script} S" <<script/>>" >html ;
: {span} S" <span>" >>html ;
: {/span} S" </span>" >>html ;
: {span/span} {span} >>html {/span} ;
' {span/span} alias {span/}
: {strong} S" **" >>html ;
: {/strong} {strong} ;
: {strong/strong} {strong} >>html {/strong} ;
' {strong/strong} alias {strong/}
: {/table} s" </table>" >html ;
: {tr} S" |" >html ;
: {/tr} cr>html ;
: {tbody} s" {* <tbody> *}" >html ;
: {/tbody} s" </tbody>" >html ;
: {td} ;
: {/td} S" |" >>html ;
: {td/td} {td} >>html {/td} ;
' {td/td} alias {td/}
: {title} S" title = " >html ;
: {/title} ;
: {title/title} ( c-addr u -- ) {title} >>html {/title} ;
' {title/title} alias {title/}
: {ul} S" {* <ul> *}" >html ;
: {/ul} cr>html cr>html ;
[ELSE]
: {/a} S" </a>" >>html ;
: {blockquote} S" <blockquote>" >html ;
: {/blockquote} S" </blockquote>" >html ;
: {body} S" <body>" >html ;
: {/body} S" </body>" >html ;
: {br} S" <br />" >>html ;
: {div} S" <div>" >html ;
: {/div} S" </div>" >html ;
: {dd} S" <dd>" >html ;
: {/dd} S" </dd>" >html ;
: {dd/dd} ( c-addr u -- ) {dd} >html {/dd} ;
' {dd/dd} alias {dd/}
: {dl} S" <dl>" >html ;
: {/dl} S" </dl>" >html ;
: {dt} S" <dt>" >html ;
: {/dt} S" </dt>" >>html ;
: {dt/dt} ( c-addr u -- ) {dt} >>html {/dt} ;
' {dt/dt} alias {dt/}
: {em} S" <em>" >>html ;
: {/em} S" </em>" >>html ;
: {em/em} ( c-addr u -- ) {em} >>html {/em} ;
' {em/em} alias {em/}
: {head} S" <head>" >html ;
: {/head} S" </head>" >html ;
: {h1} S" <h1>" >html ;
: {/h1} S" </h1>" >>html ;
: {h1/h1} ( c-addr u -- ) {h1} >>html {/h1} ;
' {h1/h1} alias {h1/}
: {h2} S" <h2>" >html ;
: {/h2} S" </h2>" >>html ;
: {h2/h2} ( c-addr u -- ) {h2} >>html {/h2} ;
' {h2/h2} alias {h2/}
: {h3} S" <h3>" >html ;
: {/h3} S" </h3>" >>html ;
: {h3/h3} ( c-addr u -- ) {h3} >>html {/h3} ;
' {h3/h3} alias {h3/}
: {h4} S" <h4>" >html ;
: {/h4} S" </h4>" >>html ;
: {h4/h4} ( c-addr u -- ) {h4} >>html {/h4} ;
' {h4/h4} alias {h4/}
: {h5} S" <h5>" >html ;
: {/h5} S" </h5>" >>html ;
: {h5/h5} ( c-addr u -- ) {h5} >>html {/h5} ;
' {h5/h5} alias {h5/}
: {h6} S" <h6>" >html ;
: {/h6} S" </h6>" >>html ;
: {h6/h6} ( c-addr u -- ) {h6} >>html {/h6} ;
' {h6/h6} alias {h6/}
: {hr} S" <hr />" >html ;
: {html} S" <html>" >html ;
: {/html} S" </html>" >html ;
: {kbd} S" <kbd>" >>html ;
: {/kbd} S" </kbd>" >>html ;
: {kbd/kbd} ( c-addr u -- ) {kbd} >>html {/kbd} ;
' {kbd/kbd} alias {kbd/}
: {li} S" <li>" >html ;
: {/li} S" </li>" >>html ;
: {li/li} ( c-addr u -- ) {li} >>html {/li} ;
' {li/li} alias {li/}
: {/object} S" </object>" >html ;
: {ol} S" <ol>" >html ;
: {/ol} S" </ol>" >html ;
: {p} S" <p>" >html ;
: {/p} S" </p>" >>html ;
: {p/p} ( c-addr u -- ) {p} >>html {/p} ;
' {p/p} alias {p/}
: {pre} S" <pre>" >html ;
: {/pre} S" </pre>" >>html ;
: {pre/pre} ( c-addr u -- ) {pre} >html {/pre} ;
' {pre/pre} alias {pre/}
: {/script} S" </script>" >html ;
: {span} S" <span>" >>html ;
: {/span} S" </span>" >>html ;
: {span/span} {span} >>html {/span} ;
' {span/span} alias {span/}
: {strong} S" <strong>" >>html ;
: {/strong} S" </strong>" >>html ;
: {strong/strong} {strong} >>html {/strong} ;
' {strong/strong} alias {strong/}
: {/table} s" </table>" >html ;
: {tr} S" <tr>" >html ;
: {/tr} S" </tr>" >html ;
: {tbody} s" <tbody>" >html ;
: {/tbody} s" </tbody>" >html ;
: {td} S" <td>" >html ;
: {/td} S" </td>" >>html ;
: {td/td} {td} >>html {/td} ;
' {td/td} alias {td/}
: {title} S" <title>" >html ;
: {/title} S" </title>" >>html ;
: {title/title} ( c-addr u -- ) {title} >>html {/title} ;
' {title/title} alias {title/}
: {ul} S" <ul>" >html ;
: {/ul} S" </ul>" >html ;
[THEN]
\ .............................................................
\ HTML entities
: S" " >>html ;
\ .............................................................
\ HTML entities
\ .............................................................
\ Untag tool
false [IF]
\ This first version of UNTAG changes the string it receives.
\ That made it impossible to use the original content later.
VARIABLE untag? untag? on
VARIABLE untag-lenght
VARIABLE untag-from
VARIABLE untag-to
: untag ( c-addr1 u1 -- c-addr1 u2 )
\ Remove all HTML tags of a string.
\ 2006-09-01
2DUP untag-lenght !
DUP untag-from ! untag-to !
BEGIN
untag-lenght @
WHILE
untag-from @ C@
CASE
[CHAR] < OF untag? off ENDOF
[CHAR] > OF untag? on ENDOF
untag? @
IF
untag-from @ C@ untag-to @ C!
1 untag-to +!
THEN
ENDCASE
1 untag-from +!
-1 untag-lenght +!
REPEAT
untag-from @ untag-to @ - -
;
\ This second version of UNTAG had a bug:
\ it always returned the string in the same address!
\ That made it impossible to use the result later without moving it to a secure place.
VARIABLE untag? \ state
svariable untagged \ used only as a allocated space, the string lenght will not be updated
VARIABLE untag-from \ current char address of the original string
VARIABLE untag-to \ current char address of the new string
: untag ( c-addr1 u1 -- c-addr2 u2 )
\ Remove all HTML tags of a string.
\ 2006-09-05
untagged COUNT DROP untag-to !
SWAP untag-from !
untag? on
BEGIN
DUP
WHILE
untag-from @ C@
CASE
[CHAR] < OF untag? off ENDOF
[CHAR] > OF untag? on ENDOF
untag? @
IF
untag-from @ C@ untag-to @ C!
1 CHARS untag-to +!
THEN
ENDCASE
1 CHARS untag-from +!
1- \ counter
REPEAT
DROP \ counter
untagged COUNT DROP untag-to @ OVER -
;
[THEN]
\ The solution is simple, at last:
\ The first version with an initial call to move the string into the string buffer!
VARIABLE untag? untag? on
VARIABLE untag-lenght
VARIABLE untag-from
VARIABLE untag-to
: untag ( c-addr1 u1 -- c-addr1 u2 )
\ Remove all HTML tags of a string.
\ 2006-09-01
\ 2007-04-08
>sbuffer
2DUP untag-lenght !
DUP untag-from ! untag-to !
BEGIN
untag-lenght @
WHILE
untag-from @ C@
CASE
[CHAR] < OF untag? off ENDOF
[CHAR] > OF untag? on ENDOF
untag? @
IF
untag-from @ C@ untag-to @ C!
1 untag-to +!
THEN
ENDCASE
1 untag-from +!
-1 untag-lenght +!
REPEAT
untag-from @ untag-to @ - -
;
\ .............................................................
\ HTML attributes
: html-attribute ( c-addr1 u1 c-addr2 u2 -- )
\ Create an HTML tag attribute if the content is provided.
\ c-addr1 u1 = attribute content or empty string
\ c-addr2 u2 = attribute label (e.g. alt, title, httplang, longdesc...)
2SWAP DUP IF
space>html 2SWAP >>html
S" ='" >>html >>html tick>html
ELSE
2DROP 2DROP
THEN
;
: >html-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = attribute content
\ c-addr2 u2 = attribute label
\ c-addr3 u3 = attribute ready for a HTML tag
S" " 2SWAP str+
S" ='" str+ 2SWAP str+ S" '" str+
;
: >title-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = title attribute content
\ c-addr2 u2 = title attribute ready for a HTML tag
S" title" >html-attribute
;
: +title-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = title attribute content
\ c-addr3 u3 = ready attributes with the title one added
>title-attribute str+
;
: >alt-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = alt attribute content
\ c-addr2 u2 = alt attribute ready for a HTML tag
S" alt" >html-attribute
;
: +alt-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = alt attribute content
\ c-addr3 u3 = ready attributes with the alt one added
>alt-attribute str+
;
: >hreflang-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = hreflang attribute content
\ c-addr2 u2 = hreflang attribute ready for a HTML tag
S" hreflang" >html-attribute
;
: +hreflang-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = hreflang attribute content
\ c-addr3 u3 = ready attributes with the hreflang one added
>hreflang-attribute str+
;
: >longdesc-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = longdesc attribute content
\ c-addr2 u2 = longdesc attribute ready for a HTML tag
S" longdesc" >html-attribute
;
: +longdesc-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = longdesc attribute content
\ c-addr3 u3 = ready attributes with the longdesc one added
>longdesc-attribute str+
;
: >accesskey-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = accesskey attribute content
\ c-addr2 u2 = accesskey attribute ready for a HTML tag
S" accesskey" >html-attribute
;
: +accesskey-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = accesskey attribute content
\ c-addr3 u3 = ready attributes with the accesskey one added
>accesskey-attribute str+
;
: >width-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = width attribute content
\ c-addr2 u2 = width attribute ready for a HTML tag
S" width" >html-attribute
;
: +width-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = width attribute content
\ c-addr3 u3 = ready attributes with the width one added
>width-attribute str+
;
: >height-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = height attribute content
\ c-addr2 u2 = height attribute ready for a HTML tag
S" height" >html-attribute
;
: +height-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = height attribute content
\ c-addr3 u3 = ready attributes with the height one added
>height-attribute str+
;
: >class-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = class attribute content
\ c-addr2 u2 = class attribute ready for a HTML tag
S" class" >html-attribute
;
: +class-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = class attribute content
\ c-addr3 u3 = ready attributes with the class one added
>class-attribute str+
;
: >type-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = type attribute content
\ c-addr2 u2 = type attribute ready for a HTML tag
S" type" >html-attribute
;
: +type-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = type attribute content
\ c-addr3 u3 = ready attributes with the type one added
>type-attribute str+
;
: >xml:lang-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = lang attribute content (ISO language code)
\ 2009-10-22 Written to be used in the Atom addon of forthCMS.
\ 2009-10-24 Siplified with >HTML-ATTRIBUTE . Typo corrected.
S" xml:lang" >html-attribute
;
: +xml:lang-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = lang attribute content (ISO language code)
\ c-addr3 u3 = ready attributes with the lang one added
\ 2009-10-24
>xml:lang-attribute str+
;
: xml:lang-enough? ( -- f )
\ 2009-10-22 Sintactic sugar. In the future the rule could be more complex.
xhtml11
;
: >lang-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = lang attribute content (ISO language code)
\ 2006-09-02 Factored from >SPAN-LANG .
\ 2006-09-03 Bug fixed.
\ 2007-04-11 Improved to distingish XHTML 1.1.
\ 2009-10-22 Factored out with >XML:LANG-ATTRIBUTE . Simplified.
[ 0 ] [if] \ old version, until 2009-10-22
xhtml11 IF
S" xml:lang='" 2SWAP
ELSE
S" xml:lang='" 2OVER str+
S" ' lang='" str+ 2SWAP
str+ S" '" str+
THEN
[then]
\ Version 2009-10-22
2dup >xml:lang-attribute 2swap
xml:lang-enough? 0= if
S" lang='" 2swap str+ s" '" str+ str+
else
2drop
then
;
: +lang-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = lang attribute content (ISO language code)
\ c-addr3 u3 = ready attributes with the lang one added
>lang-attribute str+
;
: >rel-attribute ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = rel attribute content
\ c-addr2 u2 = rel attribute ready for a HTML tag
S" rel" >html-attribute
;
: +rel-attribute ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ c-addr1 u1 = ready attributes or empty string
\ c-addr2 u2 = rel attribute content
\ c-addr3 u3 = ready attributes with the rel one added
>rel-attribute str+
;
: >span-lang ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ Insert the attribute for the provided language code in the string.
\ c-addr1 u1 = string
\ c-addr2 u2 = ISO language code
\ c-addr3 u3 = new string
\ 2006-06-27
\ 2006-09-02 Factored out to >LANG-ATTRIBUTE .
S" <span " 2SWAP >lang-attribute str+
S" >" str+ 2SWAP str+
S" </span>" str+
;
: >span-lang-es ( c-addr1 u1 -- c-addr2 u2 )
\ 2006-06-27
\ Insert the Spanish language atribute in the string.
S" es" >span-lang
;
: >span-lang-eo ( c-addr1 u1 -- c-addr2 u2 )
\ 2006-06-27
\ Insert the Esperanto language atribute in the string.
S" eo" >span-lang
;
: >span-lang-en ( c-addr1 u1 -- c-addr2 u2 )
\ 2006-06-27
\ Insert the English language atribute in the string.
S" en" >span-lang
;
: >span-lang-de ( c-addr1 u1 -- c-addr2 u2 )
\ 2006-06-27
\ Insert the German language atribute in the string.
S" de" >span-lang
;
\ .............................................................
\ Meta tags
: {meta} ( c-addr1 u1 c-addr2 u2 -- )
\ Create a meta tag.
\ c-addr1 u1 = content
\ c-addr2 u2 = name
\ 2007-04-05
\ 2010-10-08 Support for Simplilo's format output.
simplilo? IF
>html S" = " >>html >>html
ELSE
S" <meta name='" >html >>html
S" ' content='" >>html >>html
S" ' />" >>html
THEN
;
: {link} ( c-addr1 u1 c-addr2 u2 -- )
\ Create a link tag.
\ c-addr1 u1 = attributes
\ c-addr2 u2 = href
\ 2007-04-05
S" <link href='" >html >>html tick>html space>html >>html S" />" >>html
;
\ .............................................................
\ Links
: {a-href ( -- )
\ Open the start <a> tag with the href attribute.
simplilo?
IF S" [[ "
ELSE S" <a href='"
THEN >>html
;
: {a-href-http ( -- )
\ Open the start <a> tag with the href attribute and adds the http protocol.
\ 2007-05-06
{a-href S" http://" >>html
;
: a} ( c-addr1 u1 c-addr2 u2 -- )
\ Close the start <a> tag adding the href content and the attributes.
\ c-addr1 u1 = attributes
\ c-addr2 u2 = href
>>html tick>html space>html >>html S" >" >>html
;
: {a-href-http}
( c-addr1 u1 c-addr2 u2 -- ) \ with HTML output
( c-addr1 u1 c-addr2 u2 c-addr3 u3 -- ) \ with Simplilo's format output
\ Create a start <a> tag for an external link, with all its content.
\ c-addr1 u1 = attributes
\ c-addr2 u2 = href without the http protocol.
\ c-addr3 u3 = link text
\ 2007-04-05 Renamed (formerly HTTP{A} ) and rewriten.
\ 2010-10-22 Support for Simplilo's format output.
simplilo?
IF
2SWAP {a-href-http
S" | " >>html
S" | " >>html
ELSE
{a-href-http
THEN
a}
;
: {a} ( c-addr1 u1 c-addr2 u2 -- )
\ Create a <a> tag.
\ c-addr1 u1 = attributes
\ c-addr2 u2 = whole href (with http protocol if needed)
\ 2007-04-06
{a-href a}
;
: {a/a} ( c-addr1 u1 c-addr2 u2 c-addr3 u3 -- )
\ Create a link.
\ c-addr1 u1 = text
\ c-addr2 u2 = attributes
\ c-addr3 u3 = whole href (with http protocol if needed)
\ 2004 04 29
simplilo? IF
S" [[ " >>html >>html
2SWAP S" | " >>html >>html
S" | " >>html >>html
S" ]]" >>html
ELSE
{a} >>html {/a}
THEN
;
.( fhp-tags ok!)
fhp-ml.fs
CR .( fhp-ml )
\ Copyright (C) 2006,2007,2014 Marcos Cruz (programandala.net)
\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp.html).
\ This module provides the multilingual tools.
\ fhp is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2 of the License, or
\ (at your option) any later version.
\
\ fhp is distributed in the hope that it will be useful, but
\ WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\ General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with fhp; if not, see <http://gnu.org/licenses>.
\ fhp is written in the Forth language
\ with Gforth (http://gnu.org/software/gforth/).
\ .............................................................
\ To do
\ -finish every-ndup
\ -fix the order commands in 2execute/lang
\ .............................................................
\ History (in reversed order)
\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2014-04-07: '((+extension))' factored out from '(+extension)';
\ needed by ForthCMS2Fendo.
\
\ 2007-10-03: DUP/LANG renamed to EVERY-DUP . 2DUP/LANG renamed to
\ EVERY-2DUP . Kernel words defered to make possible page language
\ control in forthCMS.
\
\ 2007-06-19: 'ISO-CODE renamed to ''ISO-CODE .
\
\ 2007-06-18: New value DEFINED-LANGS to keep the original LANGS value
\ when changing between debug and normal modes. This was needed to
\ implement DEBUG-MODE and NORMAL-MODE in the forthCMS layer (formerly
\ they were defined in every application, where the number of defined
\ languages is known).
\
\ 2007-04-12: CURRENT-PAGE variable and CURRENT-PAGE? word deprecated.
\ A new word in the forthcms-pagestruct module, CURRENT-PAGE-FILE? ,
\ will do the job of the CURRENT-PAGE?
\
\ 2007-04-10: More flexible and configurable language creation system.
\ New words: MAX-LANGS , ''ISO-CODES , 'ISO-CODE and ISO-CODE .
\ >ISO-LANG is deleted. Now its job is done by ISO-CODE .
\
\ 2007-04-08: Added EVERY-CMS-TITLE-LINK . +EVERY-LANG renamed to
\ 2EXECUTE/LANG .
\
\ 2007-04-07: Added [EVERY] and (EVERY) . EVERY is not immediate any
\ more (there was no need for that). The old EVERY-LANG is needed no
\ more. It made the function (EVERY) does now. It is clearer to use
\ [EVERY] and EVERY . The word MULTILINGUAL: is renamed as
\ ML-SCONSTANT to be parallel with ML-SVARIABLE .
\
\ 2007-03-30: Added DUP/LANG , needed when implementing page-id% as
\ parameter for CREATE-PAGES instead of the page file.
\
\ 2007-02-07: +".HTML" is moved to the fhp-path module, so it can be
\ used also in monolingual sites. +EXTENSION is moved to the fhp-path
\ module and defered, so it can be used also in monolingual sites. By
\ default it executes +".HTML" . +EXTENSION-ML is the new name for
\ the old +EXTENSION and also its defered code for multiligual sites.
\
\ 2006-11-22: New variable (ML-PAGE-TITLE) .
\
\ 2006-11-20: +"_LANG" modified and renamed to +".LANG" . Now it uses
\ a dot, the standard in language negotiation, instead of an
\ underscore.
\
\ 2006-10-04: New words 'LANG-EXTENSION? and LANG-EXTENSION? to
\ control which language needs language file extension. Formerly, all
\ languages had it but the first one.
\
\ 2006-08-24: New words LANG-COMMON-KEYWORDS and (COMMON-KEYWORDS-ML)
\ .
\
\ 2006-08-08: New variable CURRENT-PAGE , taken from a fhp
\ application. Is stores the base filename of the current HTML,
\ without language and filename extensions. Bug fixed: CURRENT-PAGE?
\ now does not call CURRENT-HTML? New word PARAMETERS/LANG and
\ related variables: #PARAMETERS and #PARAMETERS-1 .
\
\ 2006-06-26: New word 2DUP/LANG , taken from the application that
\ creates my site alinome.net/bici.
\
\ 2006-06-24: The word MULTILINGUAL: is improved. Now it works with
\ any number of languages.
\
\ 2006-03: First working version.
\ .............................................................
\ Init
MARKER fhp-ml
\ .............................................................
\ Languages
3 CONSTANT max-langs \ maximum number of languages *APP_CONFIGURATION_IS_POSSIBLE*
0 VALUE defined-langs \ number of languages defined
0 VALUE langs \ number of languages used
VARIABLE lang \ current language
-1 CONSTANT all \ dummy "language code" that means "all languages"
CREATE ''iso-codes max-langs CELLS ALLOT \ space for the addresses of the ISO codes
: ''iso-code ( u -- addr )
\ u = language code
\ addr = address of the address of the ISO code
CELLS ''iso-codes +
;
: iso-code ( u1 -- c-addr u2 )
\ u1 = language code
\ c-addr u2 = language ISO code
''iso-code @ COUNT
;
false [IF] \ old version of LANGUAGE:
: language: ( c-addr u "<spaces>name" -- )
\ Create a new language identifier
\ c-addr u = language official ISO code
\ name = language id
\ 2007-04-07
\ 2007-04-10 Rewritten.
\ 2007-06-18 The new value DEFINED-LANGS is the main counter, while LANGS is updated at the end.
HERE >R s, R> defined-langs ''iso-code ! \ compile the string and keep its address
defined-langs CONSTANT \ make the identifier
defined-langs 1+ DUP
TO defined-langs
TO langs
;
\ Obsolete examples:
\ The user app must create its own list of languages, like in this example:
\ S" es" language: es \ Castellano / Español
\ S" eo" language: eo \ Esperanto
\ S" en" language: en \ English
[THEN]
: language: ( "<spaces>name" -- )
\ Create a new language identifier
\ name = language id, usually the ISO language code
\ 2007-06-19 New smarter version.
BL WORD COUNT
DUP 0= ABORT" Input stream exhausted in LANGUAGE:"
HERE >R 2DUP s, R> defined-langs ''iso-code ! \ compile the string and keep its address
S" defined-langs CONSTANT " 2SWAP str+ EVALUATE \ create the constant identifier
defined-langs 1+ DUP TO defined-langs TO langs \ update the counters
;
\ *APP_CONFIGURATION_IS_MANDATORY*
\ The user app must create its own list of languages, like in this example:
\ language: es \ Castellano / Español
\ language: eo \ Esperanto
\ language: en \ English
\ And then some syntactic sugar to make the source code easier (as explained later in this file):
\ : :es es :lang ;
\ : :eo eo :lang ;
\ : :en en :lang ;
: iso-lang ( -- c-addr u )
\ Return the ISO code of the current language.
\ c-addr u = ISO code
\ 2006-09-09 Factored out to >ISO-LANG
\ 2007-04-10 Modified.
lang @ iso-code
;
CREATE page-fids max-langs CELLS ALLOT \ file id of every language version
: +lang ( a-addr1 -- a-addr2 )
\ Change an address depending on the current language.
\ a-addr1 = base address.
\ a-addr2 = address offsetted for the current language.
\ 2008-07-19 Factored from ML-CONSTANT@ and LANG-FID .
lang @ CELLS +
;
: lang-fid ( -- a-addr )
\ 2006-03-14
\ Calculate the current language address in page-fids .
page-fids +lang
;
: save-html-fid ( -- )
\ 2006-03-14
html-fid @ lang-fid !
;
: restore-html-fid ( -- )
\ 2006-03-14
lang-fid @ html-fid !
;
: lang>html iso-lang >>html ;
\ .............................................................
\ Language selection
0 VALUE '(>>all-html) \ later calculated
: monolingual-mode ['] (>>html) is >>html ;
: multilingual-mode '(>>all-html) is >>html ;
: :lang ( u -- ) lang ! restore-html-fid monolingual-mode ;
: :all multilingual-mode all lang ! ; \ activate all pages
\ *APP_CONFIGURATION_IS_MANDATORY*
\ Language selection words like these must be defined by the user app, after defining the languages:
\ : :es es :lang ; \ activate the Spanish page
\ : :eo eo :lang ; \ activate the Esperanto page
\ They will be used in the source that builds the XTHML.
VARIABLE saved-lang
: save-lang ( -- )
\ Save the current language.
lang @ saved-lang !
;
: restore-lang ( -- )
\ Restore de language saved by SAVE-LANG .
saved-lang @ DUP all =
IF DROP :all
ELSE :lang
THEN
;
\ .............................................................
\ Stack parameters duplication
\ These words duplicate parameters in the stack as many times as the number of languages used.
\ That is needed before executing code for every language with EVERY , [EVERY] or 2EXECUTE/LANG (see later).
\ The defered core words are re-vectored in the source file forthcms-ml.f, to make possible the page language control,
\ that is, not every language are efective in the loop, but just the languages the actual page has versions in.
2VARIABLE every-2parameter \ to keep the cell that EVERY-2DUP must duplicate
defer (every-2dup)
: default-(every-2dup) ( u -- x1 x2 )
\ u = language id
DROP every-2parameter 2@
;
' default-(every-2dup) is (every-2dup)
: every-2dup ( c-addr1 u1 -- c-addr1 u1 | c-addr1 u1 ... c-addr-n u-n )
\ Duplicate the string on the stack for every language other than the main one.
\ 2006-06-26
\ First version, when ?DO was not yet implemented in Forth 5mx:
\ langs
\ BEGIN 1- DUP
\ WHILE >R 2DUP R>
\ REPEAT DROP
\ 2007-10-01 Factored out with the defered word (2DUP/LANG) , to make possible the page language control.
\ 2007-10-02 Loop first limit changed from 1 to 0.
every-2parameter 2!
langs 0 ?DO I (every-2dup) LOOP
;
' every-2dup alias 2dup/lang \ x!!! old name
VARIABLE every-parameter \ to keep the cell that EVERY-DUP must duplicate
defer (every-dup)
: default-(every-dup) ( u -- x )
\ u = language id
\ x = content of the variable PARAMETER
DROP every-parameter @
;
' default-(every-dup) is (every-dup)
: every-dup ( u -- u | u ... u-n )
\ Duplicate the cell on the stack for every language other than the main one.
\ 2007-03-30
\ 2007-10-01 Factored out with the defered word (DUP/LANG) , to make possible the page language control.
\ 2007-10-02 Loop first limit changed from 1 to 0.
every-parameter !
langs 0 ?DO I (every-dup) LOOP
;
' every-dup alias dup/lang \ x!!! old name
false [IF] \ obsolete!!!
VARIABLE #parameters
0 VALUE #parameters-1
: parameters/lang ( i*x n -- i*x ... i*x )
\ Duplicate n stack cells for every language other than the main one.
\ 2006-08-08
\ 2006-12-24 Bug fixed: now n can be 0 ( with ?DO instead of DO ).
\ :!!! this has to be adapted to page language control
DUP #parameters !
1- TO #parameters-1
langs
BEGIN
1- DUP
WHILE
>R
#parameters @ 0 ?DO
#parameters-1 PICK
LOOP
R>
REPEAT DROP
;
[THEN]
\ :!!!
\ New (unfinished) version of parameteres/lang :
0 VALUE #parameters \ number of parameters
0 VALUE 'parameters \ address of the temporal store space
0 VALUE 'last-parameter \ adderss of the lasta parameter in the temporal store space
: !parameters ( x1 ... xn -- )
\ Store the parameters into the temporal store space.
\ This could be done faster with MOVE and SP :!!!
\ 2007-10-03
\ 2007-10-08 Bug fixed: CELLS added.
'parameters #parameters 1- CELLS + TO 'last-parameter
#parameters 0 DO
'last-parameter I CELLS - !
LOOP
;
: every-ndup-init ( x1 ... xn n -- x1 ... xn )
\ Init the values needed by EVERY-NDUP .
\ 2007-10-03
TO #parameters
HERE TO 'parameters \ temporal store address
!parameters
;
defer (every-ndup)
: default-(every-ndup) ( u -- )
\ Put on the stack a copy of all the parameters.
\ u = language id
\ 2007-10-03
\ 2007-10-08 Bug fixed: CELLS added.
DROP \ language id is useless in this version, without page language control
#parameters 0 DO
'parameters I CELLS + @
LOOP
;
' default-(every-ndup) is (every-ndup)
: every-ndup ( x1...xn n -- x1...xn | x1...xn1 ... x1...xnn )
\ Put on the stack the upper n stack cells as many times as languages versions the current page has.
\ 2007-10-03
every-ndup-init
langs 0 DO I (every-ndup) LOOP
;
' every-ndup alias parameters/lang \ x!!! old name
: every-n2dup ( x1 x1'...xn xn' n -- x1 x1' ... xn xn' | x1 x1'...xn xn' ... x1 x1'...xnn xnn' )
\ Put on the stack the upper n stack double cells as many times as languages versions the current page has.
\ 2008-01-27
2* every-ndup
;
\ .............................................................
\ Code execution for every language
VARIABLE xt/lang \ used to keep the stack clean
defer ((every))
: default-((every)) ( u -- )
\ Default inner commands of (EVERY) .
\ u = language id
\ 2007-10-01
:lang xt/lang @ EXECUTE
;
' default-((every)) is ((every)) \ this is changed in the source file forthcms-pagestruct.f to implement page language control
: (every) ( i*x xt -- j*x )
\ Execute xt for every language.
\ The parameteres have to be repeated for all languages.
\ 2006-03-13
\ 2007-04-07 Renamed (formerly EVERY-LANG ).
\ 2007-10-01 Factored out to the defered ((EVERY)) to make possible the page language control at an upper layer.
xt/lang ! save-lang
langs 0 DO I ((every)) LOOP
restore-lang
;
: [every] ( i*x "<spaces>name" -- j*x )
\ Compile the xt of next word in the stream to call (EVERY) later.
\ Compile mode only.
\ 2007-04-07
POSTPONE ['] POSTPONE (every)
; IMMEDIATE
: every ( i*x "<spaces>name" -- j*x )
\ Execute the next word in the stream for every language.
\ 2006-05-07
' (every)
;
: 2execute/lang ( xt1 xt2 -- )
\ Execute xt1 for every language, and then xt2 also for every language.
\ xt1 = execution token that creates the needed parameters for xt2 (usually a multilingual constant or variable)
\ xt2 = execution token of main code to be executed for every language
\ 2006-05-06
\ 2007-04-08 Renamed (formerly +EVERY-LANG ).
>R (every) \ create the language versions of the text
\ 2SWAP 2ROT \ sort them 3 :!!! this should sort any number of strings!!!
R> (every)
;
\ .............................................................
\ Multilingual print
: (>>all-html) ( c-addr u -- )
\ Print a string (into the HTML file) for every language.
\ This word is used to vector the print core functions while in multilingual mode.
\ 2006-03-16
save-lang
langs 0 DO
I :lang 2DUP (>>html)
LOOP
2DROP restore-lang
;
' (>>all-html) TO '(>>all-html)
\ .............................................................
\ File names and file name extensions
svariable lang-separator S" ." lang-separator place
: +lang-separator ( c-addr1 u1 -- c-addr2 u2 )
\ 2006-12-04
lang-separator COUNT str+
;
: (+".lang") ( c-addr1 u1 u3 -- c-addr2 u2 )
\ c-addr1 u1 = file name without extension
\ u3 = language code
\ c-addr2 u2 = file name with language extension
\ 2006-12-04
>R +lang-separator R> iso-code str+
;
: +".lang" ( c-addr1 u1 -- c-addr2 u2 )
\ c-addr1 u1 = file name without extension
\ c-addr2 u2 = file name with current language extension
\ 2006-03-14
\ 2006-11-26 improved with LANG-SEPARATOR
+lang-separator iso-lang str+
;
CREATE 'lang-extension? max-langs CELLS ALLOT \ one cell flag for every language
: lang-extensions! ( flag -- )
\ Fill all language extensions flags with a flag.
'lang-extension? max-langs CELLS ROT FILL
;
true lang-extensions! \ by default, all languages have its extension activated
: lang-extension? ( u -- addr )
\ u = language code
\ addr = language flag variable
\ 2006-10-04
\ 2006-10-26 bug fixed: CELLS added!
CELLS 'lang-extension? +
;
: ((+extension)) ( c-addr1 u1 u3 -- c-addr2 u2 )
\ 2014-04-07 Factored out from '(+extension)', needed by
\ ForthCMS2Fendo.
DUP lang-extension? @
IF (+".lang") ELSE DROP THEN +".html"
;
: (+extension) ( c-addr1 u1 u3 -- c-addr2 u2 )
\ Add a extension (both language and file type) to a file name.
\ CONFIGURATION!!! This can be changed by the user if other format is prefered.
\ c-addr1 u1 = "filename" without extensions
\ u3 = language id
\ c-addr2 u2 = "filename.lang.html" where "lang" is the language code, if that language is configured so.
\ 2006-04-29
\ 2006-10-04 Improved with LANG-EXTENSION? Now the programmer can control, which language needs language file extension. Formerly, all languages had it but the first one.
\ 2006-12-04 Bug fixed. The word +".LANG" did not use the parameter but the current language! New word (+".LANG") used.
\ 2010-10-08 Support for Simplilo's format output.
\ 2012-07-31 Fendo support.
simplilo? fendo? OR IF
iso-code +lang-separator 2SWAP str+
ELSE ((+extension)) THEN
;
: +extension-ml ( c-addr1 u1 -- c-addr2 u2 )
\ 2006-03-14
\ 2006-11-20 Documented
\ 2007-02-07 Renamed from +EXTENSION to defer the translated +EXTENSION
\ Añade a un nombre de archivo el indicador de la lengua actual y la extensión.
\ c-addr1 u1 = "filename" without extensions
\ c-addr2 u2 = "filename.lang.html" where "lang" is the language code, if that language is configured so.
lang @ (+extension)
;
' +extension-ml is +extension
\ .............................................................
\ Multilingual constants and variables
\ Note:
\ Multilingual constants and variables
\ should not be executed while the current language is the dummy "all".
\ In that case, the execution will return an unpredictable result that may hang the system.
\ Use the words EVERY , [EVERY] and related to call code that uses multilingual string constant or variables.
: (ml-constant) ( x1 ... x-n -- )
\ Store the values of a multilingual constant.
\ Note: This word depends on LANGS and therefore can not be used until the languages are defined by the user application.
\ x1 = value for the last language used
\ x-n = value for the first language used
\ 2008-07-19 Adapted from (ML-SCONSTANT) .
langs 0 DO , LOOP
;
: ml-constant@ ( a-addr -- x )
\ Return the content of a multilingual constant.
\ a-addr = address of the value cells.
\ 2008-07-19 Adapted from ML-SCONSTANT@ .
+lang @
;
: ml-constant ( x1 ... x-n "<spaces>name" -- )
\ Create a word that, when executed,
\ will return one of several cells,
\ the one for the current language.
\ Note: This word depends on LANGS and therefore can not be used until the languages are defined by the user application.
\ x1 = cell for in the last language used
\ x-n = cell for the first language used
\ 2008-07-19 Adapted from ml-sconstant .
CREATE
(ml-constant) \ store all the cells "here"
DOES> ( pfa -- x )
ml-constant@ \ return the right cell
;
\ Usage:
\ 10 \ English
\ 20 \ Esperanto
\ 20 \ Castellano
\ ml-constant number
VARIABLE 'ml-constants \ :!!! needed in the Win32Forth versions
: :ml-constant ( x1 ... x-n -- xt )
\ Create a multilingual constant with no name:
\ Return an xt that, when executed, will
\ return one of the values, the one
\ for the current language.
\ This word was written to make it easier to store multilingual values
\ into the fields of a forthCMS page structure.
\ This word makes it unnecessary to define multilingual constants just to
\ store their xt into the record to be created.
\ See the file forthCMS-pagestruct.f for more info.
\ Note: This word depends on LANGS
\ and therefore can not be used
\ until the languages are defined by the user application.
\ x1 = value for the last language used
\ x-n = value for the first language used
\ xt = execution token to do the job of a multilingual constant
\ 2008-07-19 Adapted from :ML-SCONSTANT .
\ Second version.
HERE 'ml-constants ! (ml-constant)
S" :NONAME ( Compilation time: -- xt ) ( Run time: -- c-addr u ) [ 'ml-constants @ ] LITERAL ml-constant@ ;"
EVALUATE \ create the new headerless word and leave its xt on the stack
;
0 [IF] \ :!!! unfinished
VARIABLE 'ml-constant \ :!!! needed in the Win32Forth versions
: :constant ( x -- xt )
\ Create a constant with no name.
\ Return an xt that, when executed, will
\ return the value.
\ x = value
\ xt = execution token to do the job of a constant
\ 2008-07-19 Adapted from :SCONSTANT .
HERE 'constant ! s,
S" :NONAME ( Compilation time: -- xt ) ( Run time: -- c-addr u ) [ 'constant @ ] LITERAL ;"
EVALUATE \ create the new headerless word and leave its xt on the stack
;
[THEN]
: ml-variable ( "<spaces>name" -- )
\ Create a word that works as a normal variable,
\ but depends on the current language.
\ The multilingual variable keeps several values,
\ one for every language used.
\ The working is transparent to the user.
CREATE
HERE max-langs CELLS
DUP ALLOT ALIGN ERASE
DOES> ( pfa -- a-addr )
+lang
;
\ .............................................................
\ Multilingual string constants and variables
\ Note:
\ Multilingual string constants and variables
\ should not be executed while the current language is the dummy "all".
\ In that case, the execution will return an unpredictable result that may hang the system.
\ Use the words EVERY , [EVERY] and related to call code that uses multilingual string constant or variables.
: s,! ( c-addr1 u1 a-addr u -- )
\ Compile a string and keep its new address
\ into the a-addr address plus the u offset.
\ c-addr1 u1 = string
\ a-addr = base address
\ u = offset
\ 2006-03-12
CELLS + HERE SWAP ! s,
;
VARIABLE multilingual-index
: (ml-sconstant) ( a-addr1 u1 ... c-addr-n u-n -- )
\ Store the strings of a multilingual string constant.
\ Note: This word depends on LANGS and therefore can not be used until the languages are defined by the user application.
\ c-addr1 u1 = string in the last language used
\ c-addr-n u-n = string in the first language used
\ 2007-06-21 Factored from ML-SCONSTANT .
HERE multilingual-index !
langs CELLS ALLOT \ index
langs 0 DO
multilingual-index @ I s,!
LOOP
ALIGN
;
: ml-sconstant@ ( a-addr -- c-addr u )
\ Return the content of a multilingual string constant.
\ a-addr = address of the strings index.
\ 2008-01-19 Factored from ML-SCONSTANT and :ML-SCONSTANT .
\ 2008-07-19 Factored out with ML-CONSTANT@ .
ml-constant@ COUNT
;
: ml-sconstant ( a-addr1 u1 ... c-addr-n u-n "<spaces>name" -- )
\ Create a word that, when executed,
\ will return one of several texts,
\ the one in the current language.
\ Note: This word depends on LANGS and therefore can not be used until the languages are defined by the user application.
\ c-addr1 u1 = string in the last language used
\ c-addr-n u-n = string in the first language used
\ 2006-03-12
\ 2007-03-12 Little improve: CELL instead of 1 CELLS in the DOES> part.
\ 2007-04-07 Renamed (formerly MULTILINGUAL: )-
\ 2007-04-10 Little improve: CELLS instead of CELL * in the DOES> part.
\ 2007-06-21 Factored to (ML-SCONSTANT) .
\ 2008-01-19 Factored to ML-SCONSTANT@ .
CREATE
(ml-sconstant) \ store all the strings "here"
DOES> ( pfa -- c-addr u )
ml-sconstant@ \ return the right string
;
' ml-sconstant alias multilingual: \ old name
\ Usage:
\ S" XHTML 1.0 validator" \ English
\ S" Ekzamenilo de XHTML 1.0" \ Esperanto
\ S" Verificador de XHTML 1.0" \ Castellano
\ ml-sconstant "xhtml"
VARIABLE 'ml-sconstants \ :!!! needed in the Win32Forth versions
: :ml-sconstant ( a-addr1 u1 ... c-addr-n u-n -- xt )
\ Create a multilingual string constant with no name:
\ Return an xt that, when executed, will
\ return one of the strings, the one
\ in the current language.
\ This word was written to make it easier to store multilingual texts
\ into the fields of a forthCMS page structure.
\ This word makes it unnecessary to define multilingual string constants just to
\ store their xt into the record to be created.
\ See the file forthCMS-pagestruct.f for more info.
\ Note: This word depends on LANGS
\ and therefore can not be used
\ until the languages are defined by the user application.
\ c-addr1 u1 = string in the last language used
\ c-addr-n u-n = string in the first language used
\ xt = execution token to do the job of a multilingual string constant
\ 2007-06-21
\ 2007-06-28 Adapted to Win32Forth.
[ FALSE ] [IF]
\ First version.
\ This works in Forth 5mx.
\ This doesn't work in Win32Forth: it doesn't permit to change the stack while compiling a definition.
\ This doesn't work in gforth: it halts while evaluating the string with the error "unbalanced".
HERE >R (ml-sconstant) R>
S" :NONAME ( Compilation time: a-addr -- xt ) ( Run time: -- c-addr u ) ( a-addr xt -- ) [ SWAP ] LITERAL ml-sconstant@ ;"
EVALUATE \ create the new headerless word and leave its xt on the stack
[THEN]
[ TRUE ] [IF]
\ Second version.
HERE 'ml-sconstants ! (ml-sconstant)
S" :NONAME ( Compilation time: -- xt ) ( Run time: -- c-addr u ) [ 'ml-sconstants @ ] LITERAL ml-sconstant@ ;"
EVALUATE \ create the new headerless word and leave its xt on the stack
[THEN]
[ FALSE ] [IF]
\ :!!! Experimental unfinished version.
HERE >R (ml-sconstant) R>
:NONAME ( a-addr xt -- )
POSTPONE SWAP
POSTPONE ml-sconstant@
POSTPONE ;
[THEN]
;
: :sconstant ( a-addr1 u1 -- xt )
\ Create a string constant with no name:
\ Return an xt that, when executed, will
\ return the string.
\ This word was written to make it easier to migrate
\ from a monolingual website to a multilingual one,
\ using the same kind of xt field to store the strings
\ into the forthCMS page structure.
\ See the file forthCMS-pagestruct.f for more info.
\ c-addr1 u1 = string
\ xt = execution token to do the job of a string constant
\ 2007-06-21
[ FALSE ] [IF]
\ First version.
\ This works in Forth 5mx.
\ This doesn't work in Win32Forth: it doesn't permit to change the stack while compiling a definition.
\ This doesn't work in gforth: it halts while evaluating the string with the error "unstructured".
HERE >R s, R>
S" :NONAME ( Compilation time: a-addr -- xt ) ( Run time: -- c-addr u ) ( a-addr xt -- ) [ SWAP ] LITERAL COUNT ;"
EVALUATE \ create the new headerless word and leave its xt on the stack
[THEN]
[ TRUE ] [IF]
\ Second version.
HERE 'ml-sconstants ! s,
S" :NONAME ( Compilation time: -- xt ) ( Run time: -- c-addr u ) [ 'ml-sconstants @ ] LITERAL COUNT ;"
EVALUATE \ create the new headerless word and leave its xt on the stack
[THEN]
[ FALSE ] [IF]
\ :!!! Experimental unfinished version.
HERE >R s, R>
:NONAME
( Compilation time: a-addr -- xt )
( Run time: -- c-addr u )
( a-addr xt -- )
SWAP
LITERAL
POSTPONE COUNT
POSTPONE ;
[THEN]
;
: ml-svariable ( "<spaces>name" -- )
\ Create a word that works as a normal string variable,
\ but depends on the current language.
\ The multilingual string variable keeps a list
\ of addresses to strings, one for every language used.
\ The working is transparent to the user.
HERE DUP \ address of the list of addresses
max-langs CELLS DUP ALLOT ERASE
CREATE ,
DOES> ( pfa -- c-addr )
\ Return the variable content as a counted string, for the current language.
@ lang @ CELLS + \ get the address of the string
DUP @ 0= IF
\ The string for the current language has no memory space reserved yet.
HERE 256 2DUP ERASE ALLOT ALIGN \ make it
\ :!!! note: 256 should be calculated from the system.
OVER ! \ keep its address
THEN @
;
\ .............................................................
\ Misc
: >span-lang? ( c-addr1 u1 u2 -- c-addr3 u3 )
\ Mark a text with a language code, if it's not the current language.
\ c-addr1 u1 = text
\ u2 = language number
\ c-addr3 u3 = same or new string
\ 2006-09-09
DUP lang @ <>
IF iso-code >span-lang
ELSE DROP
THEN
;
.( fhp-ml ok!)
fhp-date.fs
CR .( fhp-date )
\ Copyright (C) 2006,2013 Marcos Cruz (programandala.net)
\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp).
\ This file provides the date and timing tools.
\ fhp is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2 of the License, or
\ (at your option) any later version.
\
\ fhp is distributed in the hope that it will be useful, but
\ WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\ General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with fhp; if not, see <http://gnu.org/licenses>.
\ fhp is written in the Forth language
\ with Gforth (http://gnu.org/software/gforth/).
\ .............................................................
\ History
\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2006-08-18: Created with code factored from my application
\ alinome-bici.
\
\ 2006-08-31: Several words added or improved.
\
\ 2006-09-04: New words ROT>STR+ and >META-DATE
\
\ 2013-05-18: '>iso-date' and its related code have been
\ factored out, rewritten and simplified as a module of the
\ Galope library. See
\ <http://programandala.net/en.program.galope>. The module is
\ called "yyyymmdd-to-iso.fs".
\ .............................................................
\ Code
svariable time-zone
S" +02:00" time-zone place \ system dependent time zone
\ S" CET" time-zone place \ system dependent time zone
\ S" Z" time-zone place \ alternative for UTC time zone
CREATE iso-date 10 ALLOT ALIGN
: iso-year> ( c-addr1 u1 c-addr2 -- )
\ Receive a string in the format "yyyy[mm[dd]]",
\ extract the year and place it at the beginning of the counted string at c-addr2.
\ 2006-08-10
NIP 4 SWAP place
;
: iso-month> ( c-addr1 u1 c-addr2 -- )
\ Receive a string in the format "yyyy[mm[dd]]",
\ extract the month and place it into the counted string at c-addr2,
\ that already has "yyyy".
\ 2006-08-10
SWAP 4 >
IF
DUP >R COUNT + [CHAR] - OVER C! \ put a separator after the year
1+ SWAP 4 CHARS + SWAP 2 CMOVE \ copy the 2 digits of the month
7 R> C! \ new lenght
ELSE
2DROP
THEN
;
: iso-day> ( c-addr1 u1 c-addr2 -- )
\ Receive a string in the format "yyyy[mm[dd]]",
\ extract the day and place it into the counted string at c-addr2,
\ that already has "yyyy-mm".
\ 2006-08-10
SWAP 6 >
IF
DUP >R COUNT + [CHAR] - OVER C! \ put separator
1+ SWAP 6 CHARS + SWAP 2 CMOVE \ copy the 2 digits
10 R> C! \ new lenght
ELSE
2DROP
THEN
;
: not-digit? ( c -- flag )
\ 2006-08-10
DUP [CHAR] 0 < SWAP [CHAR] 9 > OR
;
: left-digits ( c-addr1 u1 -- c-addr1 u1' )
\ Return a string removing all characters at the right of (and including) the first non digit character found.
\ 2006-08-10
DROP DUP
BEGIN
DUP CHAR+ SWAP C@ not-digit?
UNTIL
char- OVER -
;
: >iso-date ( c-addr1 u1 -- c-addr2 u2 )
\ Transform a date string with the format:
\ yyyy[mm[dd]]x*y
\ (where "yyyy", "mm" and "dd" are numeric characters
\ and "x*y" is any string that starts with a non numeric character)
\ into the format:
\ yyyy[-mm[-dd]]
\ The goal is to get the date from the name of a file that has been named that way.
\ It is also used to convert a metadata date ("change" or "created") format: "yyyymmdd".
\ 2006-08-10
left-digits
2DUP iso-date iso-year>
2DUP iso-date iso-month>
iso-date iso-day>
iso-date COUNT
;
: >iso-full-date ( c-addr1 u1 -- c-addr2 u2 )
\ Transform a date string with the format:
\ yyyymmdd
\ (where "yyyy", "mm" and "dd" are numeric characters)
\ into the format:
\ yyyy-mm-ddT00:00:00Z
\ (where Z is the time zone stored in the variable time-zone)
\ It is used to convert a metadata date ("change" or "created") format: "yyyymmdd" into
\ a standard date.
\ 2009-10-22
>iso-date s" T00:00:00" str+ time-zone count str+
;
: #>html ( u -- )
\ Send one number (part of a date) to the HTML file
\ after converting it into a string
\ and putting one left zero if needed.
\ u = year, month, day, hour, minute or second
n>str DUP 1 =
IF [CHAR] 0 emit>html
THEN
>>html
;
: 3#>html ( u1 u2 u3 c -- )
\ Send three numbers to the html file separated by a character.
\ u1 = day or second
\ u2 = month or minute
\ u3 = year or hour
\ c = separator
\ 2006-08-17
>R
#>html R@ emit>html
#>html R> emit>html
#>html
;
: time>html ( u1 u2 u3 -- )
\ u1 = hour
\ u2 = minute
\ u3 = second
\ 2006-08-17
[CHAR] : 3#>html
;
: date>html ( u1 u2 u3 -- )
\ u1 = day
\ u2 = month
\ u3 = year
\ 2006-08-17
[CHAR] - 3#>html
;
: iso-date&time>html ( u1 u2 u3 u4 u5 u6 -- )
\ Create into the HTML file a date and time string
\ with the ISO format.
\ u1 = second
\ u2 = minute
\ u3 = hour
\ u4 = day
\ u5 = month
\ u6 = year
\ 2006-08-17
\ 2006-08-20 Conformed to ISO.
\ 2006-08-31 Improved.
date>html
S" T" >>html time>html
time-zone COUNT >>html
;
: rot>str+ ( n c-addr1 u1 -- c-addr2 u2 )
\ Convert a number into a string and append it to a given string.
\ 2006-09-04
ROT n>str str+
;
: >meta-date ( u1 u2 u3 u4 u5 u6 -- )
\ Return a date and time string
\ in the format used by the <meta> tag:
\ yyyymmdd;hhmmss
\ u1 = second
\ u2 = minute
\ u3 = hour
\ u4 = day
\ u5 = month
\ u6 = year
\ 2006-09-04
n>str rot>str+ rot>str+
S" ;" str+
rot>str+ rot>str+ rot>str+
;
false [IF] \ obsolete!!!
: meta-date>html ( u1 u2 u3 u4 u5 u6 -- )
\ Create into the HTML file a date and time string
\ in the format used by the <meta> tag:
\ yyyymmdd;hhmmss
\ u1 = second
\ u2 = minute
\ u3 = hour
\ u4 = day
\ u5 = month
\ u6 = year
\ 2006-08-31
#>html #>html #>html
[CHAR] ; emit>html
#>html #>html #>html
;
[THEN]
.( fhp-date ok!)
fhp-img.fs
CR .( fhp-img )
\ Copyright (C) 2006,2010,2011 Marcos Cruz (programandala.net)
\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp).
\ This module provides the image tags and tools.
\ fhp is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2 of the License, or
\ (at your option) any later version.
\
\ fhp is distributed in the hope that it will be useful, but
\ WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\ General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with fhp; if not, see <http://gnu.org/licenses>.
\ fhp is written in the Forth language
\ with Gforth (http://gnu.org/software/gforth/).
\ .............................................................
\ History
\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2006-08-08: Added code written for my application alinome-bici.
\
\ 2010-10-07: First support for Simplilo's format output.
\ .............................................................
\ Init
MARKER fhp-img
\ -----------------------------------------
\ Code
false [IF] \ obsolete!!!
\ 2006-08-31: not used anymore
: img-size ( c-addr1 u1 -- c-addr2 u2 )
\ Return a string with the KiB size of the image.
\ c-addr1 u1 = image file, without img-dir and img-subdir
\ c-addr2 u2 = result
\ 2006 07 02
\ 2006 08 10 Now it calculates the whole local path.
\ 2006-08-31 Now it does not include parenthesis.
+img-disk-path
R/O OPEN-FILE ABORT" OPEN-FILE error in img-size"
DUP >R FILE-SIZE ABORT" FILE-SIZE error in img-size"
D>S 1024 / n>str
S" <abbr class='first' lang='en' xml:lang='en' title='Kibibytes'>KiB</abbr>" str+
R> CLOSE-FILE ABORT" CLOSE-FILE error in img-size"
;
[THEN]
: img-xy ( c-addr u -- x y )
\ Return an image's width and height in pixels.
\ 2006 06 29
\ 2006 08 10 Now it calculates the whole local path.
\ c-addr u = image file, without img-dir and img-subdir
\ x = width
\ y = height
+img-disk-path
jpg-open jpg-xy
ROT CLOSE-FILE ABORT" CLOSE-FILE error in img-xy"
;
: singlequotes>doublequotes ( a u -- )
\ Convert single to double quotes in a string.
\ 2011-02-11 First version.
s" '" str-quotes str-exchange-all
;
: attrs>attrs+alt ( a1 u1 -- a2 u2 a3 u3 )
\ Extract the alt attr content from image HTML attributes.
\ a1 u1 = image attrs, with possible alt the start.
\ a2 u2 = image attrs without the alt.
\ a3 u3 = content of the alt attribute, or empty string if no alt.
\ Note: the alt attribute, if present, is always at the start, and only single quotes are used, what make things much easier.
\ 2011-02-11 First version.
s" alt='" search
if \ alt text found
5 /string \ remove the string searched for
over >r \ save the start of the alt text
s" '" search
0= abort" Closing quote is missing in image 'alt' attribute."
1 /string \ remove the single quote searched for
over r@ - 1- r> swap \ calculate the content of the alt attribute
else
s" " \ alt text is empty
then
2swap singlequotes>doublequotes 2swap
;
defer img
svariable img-align-class \ used for exporting to Simplilo format
: default-img ( c-addr1 u1 c-addr2 u2 -- )
\ Insert a JPEG image in the HTML page.
\ c-addr1 u1 = attributes
\ c-addr2 u2 = image file, without img-dir and img-subdir
\ 2006 04 01
\ 2006 08 10 Now it uses +img-url-path .
\ 2010-10-08 First support for Simplilo's format output. Unfinished.
\ 2011-02-10 Finnished the support for Simplilo's format output.
\ 2011-02-11 Fixed. Single quotes are changed to double quotes in the HTML parameters of the Simplilo's format output. Single quotes caused rendering problems later, I don't know why.
\ 2011-01-11 Factored out to attrs>attrs+alt .
simplilo? IF
S" {{ " >html +img-url-path >>html
attrs>attrs+alt
S" | " >>html >>html \ alt text
S" | " >>html
img-align-class count str+ >>html \ add the image align class to the remaining attrs
S" }}" >>html
ELSE
S" <img src='" >html
2DUP +img-url-path >>html tick>html
img-xy
n>str >height-attribute >>html
n>str >width-attribute >>html
space>html >>html S" />" >>html
THEN
;
' default-img is img
: leftimg{ ( -- )
simplilo?
IF
S\" class=\"left\"" img-align-class str!
\ S" <<div leftimg />>" >html
ELSE S" <div class='leftimg'>" >html
THEN
;
: rightimg{ ( -- )
simplilo?
IF
S\" class=\"right\"" img-align-class str!
\ S" <<div rightimg />>" >html
ELSE S" <div class='rightimg'>" >html
THEN
;
: centerimg{ ( -- )
simplilo?
IF
S\" class=\"center\"" img-align-class str!
\ S" <<div centerimg />>" >html
ELSE S" <div class='centerimg'>" >html
THEN
;
simplilo? [IF]
' noop
[ELSE]
' {/div}
[THEN]
DUP DUP
alias }leftimg
alias }rightimg
alias }centerimg
: |img ( c-addr1 u1 c-addr2 u2 -- )
\ Make an image on the left.
\ c-addr1 u1 = attributes
\ c-addr2 u2 = image file, without img-dir and img-subdir
\ 2006-04-02 First and third version.
\ S" <div class='leftimg'>" >html img {/div}
\ 2006-10-09 Second version.
\ 2>R S" class='left'" str+ 2R> img
\ 2009-08-21 Fourth version.
leftimg{ img }leftimg
;
: img| ( c-addr1 u1 c-addr2 u2 -- )
\ Make an image on the right.
\ c-addr1 u1 = attributes
\ c-addr2 u2 = image file, without img-dir and img-subdir
\ 2006 04 02 First and third version.
\ S" <div class='rightimg'>" >html img {/div}
\ 2006-10-09 Second version.
\ 2>R S" class='right'" str+ 2R> img
\ 2009-08-21 Fourth version.
rightimg{ img }rightimg
;
: |img| ( c-addr1 u1 c-addr2 u2 -- )
\ Make an image on the centre.
\ c-addr1 u1 = attributes
\ c-addr2 u2 = image file, without img-dir and img-subdir
\ 2006-04-02 First and third version.
\ S" <div class='centerimg'>" >html img {/div}
\ 2006-10-09 New version.
\ 2>R S" class='center'" str+ 2R> img
\ 2009-08-21 Fourth version.
centerimg{ img }centerimg
;
.( fhp-img ok!)
fhp-benchs.fs
CR .( fhp-benchs )
\ Copyright (C) 2006 Marcos Cruz (programandala.net)
\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp).
\ This file makes a speed test for debugging purposes.
\ fhp is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2 of the License, or
\ (at your option) any later version.
\
\ fhp is distributed in the hope that it will be useful, but
\ WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
\ General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with fhp; if not, see <http://gnu.org/licenses>.
\ fhp is written in the Forth language
\ with Gforth (http://gnu.org/software/gforth/).
\ .............................................................
\ Init
[undefined] fhp [IF] S" fhp.f" INCLUDED [THEN]
html-make off
html-echo off
\ .............................................................
\ Benchs
VARIABLE html[-speedtest
VARIABLE html\-speedtest
VARIABLE html(-speedtest
html[-speedtest on
html\-speedtest off
html(-speedtest off
html[-speedtest @ [IF]
CR .( html[ speed test)
TIME&DATE
:NONAME
html[
bla bla bla (long XHTML text here!)
]html
;
DROP -seconds
CR . .( seconds with html[ )
[THEN]
html(-speedtest @ [IF]
CR .( html( speed test)
TIME&DATE
html(
bla bla bla (long XHTML text here!)
)html
-seconds
CR . .( seconds with html( )
[THEN]
html\-speedtest @ [IF]
CR .( html\ speed test)
TIME&DATE
html\
bla bla bla (long XHTML text here!)
-seconds
CR . .( seconds with html\ )
[THEN]
\ 2006-04-26: Results (with Forth 5mx on a Psion 5mx):
\
\ original html[ 423 s
\ html\ 279 s (34% faster)
\ compile mode html[ 61 s
\ interpretation mode html( 399 s