fhp
Description of the page content
Forth tools to create HTML documents.
Tags:
fhp is a toolkit I wrote in order to build XHTML web pages. It soon became the low-level layer of a more complex program, an actual website engine, called ForthCMS.
I developed and used fhp with my own Forth 5mx written for the Psion 5mx. Some years later I adapted fhp to work also on Gforth.
Source code
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