---

fjpg

Mi verkis ĉi programon kiel komplementon al alia mia, nomita fhp, ĉar mi bezonis koni la grandon de bildoj. La programo estas facile ĝustigebla por preni aliajn datenojn el la bildoj.

Fontkodo

\ ---------------------------------------------
cr .( fjpg )

\ Copyright (C) 2006,2007,2009,2013,2014 Marcos Cruz (programandala.net)
\ Licencia/License/Permesilo: http://programandala.net/license

\ Herramientas para leer información de archivos JPEG.
\ Info-legiloj por JPEG-dosieroj.
\ Tools to read JPEG files information.

\ Programa escrito en Forth con Gforth.
\ Programo verkita en Fortho per Gforth.
\ Program written in Forth with Gforth.

\ ---------------------------------------------
\ History

\ 2014-02-28: Typo fixed in comment.

\ 2014-02-24: Copied to Galope in order to improve it and reuse it.
\ Typos fixed in comments. '2+' and '2-' changed to '2 +' and '2 -'
\ por Gforth.

\ 2013-09-25: Changes in the source: no tabs, no spaces at the end of
\ lines, no empty lines... ANS Forth removed from the header. Forth
\ words are changed to lowercase.

\ 2009-02-20: New word: 'jpg-close'.

\ 2007-10-19: Bug found and fixed: The x and y are not found in
\ pictures taken with a Nikon Coolpix 3100.  The reason was that the
\ JPEG size header was after the first 16 KiB, the size of the used
\ buffer.  But my Forth 5mx 'read-file' word had a limitation
\ inherited from the OPL command ioread(): it could not read more than
\ 16 KiB in a single operation.  So i wrote a new OPL procedure to
\ call ioread as many times as needed to read the desired lenght.
\ Then I increased the JPEG buffer to 64 KiB, what seems enough...
\ 'jpg-search2' and 'jpg-search-xy' were written for debugging this.

\ 2006-04-03: '.jpg-data' improved: Now you can 'abort' also *before*
\ the dumping.  'jpg-dump' modified: Now it doesn't show the data
\ bytes out of the headers.

\ 2006-04-02: '.jpg-data' improved: Now it asks for confirmation
\ *before* the dumping.

\ 2006-04-01: 'jpg-xy' fixed: it returned y x insted of x y.

\ 2006-03-30: First working version of 'jpg-xy'.

\ 2006-03-29: First working version of 'jpg-dump'.

\ 2006-03-28: Start. My first goal is to get the width and height of a
\ JPEG image file.  i need that to improve my program fhp, a Forth
\ HTML Preprocessor.

\ ---------------------------------------------

marker fjpg

: 16@  ( c-addr -- n )
  \ Fetch litle-endian 16 bits.
  dup c@ 256 * swap 1+ c@ +
  ;
65536 constant #jpg-buffer  \ must be enough to hold all JPEG headers we will need
create jpg-buffer #jpg-buffer allot
: jpg-load  ( fileid -- )
  \ Fill the buffer with the beginning of the a jpeg image file, to make it the current one.
  [ base @ hex ]
  jpg-buffer #jpg-buffer
  2dup erase
  rot read-file abort" Read image file error in jpg-load ."
  drop jpg-buffer @ ffff and d8ff <> abort" Not a JPEG file in jpg-load ."
  [ base ! ]
  ;
variable jpg-fileid
: jpg-open  ( c-addr u -- fileid )
  \ Open a JPEG image file and make it the current one.
  [ base @ hex ]
  r/o bin open-file abort" JPEG image open file error in jpg-open ."
  dup jpg-fileid !
  dup jpg-load
  [ base ! ]
  ;
: jpg-close  ( -- )
  \ Close the current JPEG image.
  jpg-fileid @ close-file abort" JPEG image close file error in jpg-close ."
  ;
: >jpg-data  ( c-addr -- c-addr2 u2 )
  \ c-addr = address of a JPEG marker
  \ c-addr2 u2 = data region of the JPEG header
  dup 4 + swap 2 + 16@ 2 -
  ;
: >jpg-marker  ( c-addr -- u )
  \ c-addr = address of a JPEG marker
  \ u = byte offset from c-addr to the next JPEG marker
  2 + 16@ 2 +
  ;
: .jpg-data  ( c-addr u -- )
  \ Dump the data of a JPEG header.
  cr ." [d]ump? [a]bort? Any other key to continue" cr
  key  case
  [char] d
    of
      cr dump
      ." [a]bort? Any other key to continue" cr
      key [char] a =
      if  abort  then
    endof
  [char] a  of  abort  endof
  >r 2drop r>  \ discard data, savig the case selector
  endcase
  ;
: .jpg-header  ( c-addr -- u )
  \ show a jpeg header.
  \ c-addr = address of a jpeg marker
  \ u = byte offset from c-addr to the next marker
  dup >jpg-data 2dup
  ." , " . ." bytes from " . ." :"
  .jpg-data  >jpg-marker
  ;
: >jpg-xy  ( c-addr -- x y )
   \ c-addr = address of the proper jpeg marker
   \ x y = size of the jpeg image
  7 + dup 16@ swap 2 - 16@
  ;
: .jpg-xy  ( c-addr -- )
  \ show the jpeg image size.
  \ c-addr = address of the proper jpeg marker
  >jpg-xy swap ."  x=" . ." y=" .
  ;
: jpg-header  ( c-addr -- n )
  \ identify and show a new jpeg header.
  \ c-addr = address of the jpeg marker
  \ u = byte offset to the next marker, or 0 if the marker found was the end of image
  [ base @ hex ]
  dup 1+ c@  dup .  ." marker: "
  case  \ marker id
  c0  of  ." frame" dup .jpg-xy .jpg-header  endof
  c1  of  ." unknown (frame?)" dup .jpg-xy .jpg-header  endof  \ xxx debug 2007-10-19
  c2  of  ." unknown (frame?)" dup .jpg-xy .jpg-header  endof
  c3  of  ." unknown (frame?)" dup .jpg-xy .jpg-header  endof  \ xxx debug 2007-10-19
  c4  of  ." define huffman table" .jpg-header  endof
  \ from e0 to ef are reserved for applications:
  e0  of  ." jfif" .jpg-header  endof
  e1  of  ." exim" .jpg-header  endof
  d8  of  ." start of image" drop 2  endof
  d9  of  ." end of image" drop 0  endof
  da  of  ." start of scan" .jpg-header  endof
  db  of  ." define quantization" .jpg-header  endof
  fe  of  ." comment" .jpg-header  endof
  >r  \ preserve case selector for endcase
  ." unknown" .jpg-header
  r>
  endcase
  [ base ! ]
  ;
: jpg-xy  ( -- x y )
  \ return the size of the current jpeg file.
  [ base @ hex ]
  jpg-buffer dup #jpg-buffer + swap 2 +
  do
    i 16@
    case
    ffc0  of  i >jpg-xy leave  endof
    ffc2  of  i >jpg-xy leave  endof
    endcase
    i >jpg-marker
  +loop
  [ base ! ]
  ;
\ debug tools
: jpg-dump  ( -- )
  \ dump the content of the current jpeg image, header after header, until the buffer end.
  \ this word was written to learn about the jpeg format and write the other words.
  [ base @ hex ]
  jpg-buffer dup #jpg-buffer + swap
  do
    i dup cr . ." : "
    dup c@ dup .
    ff =
    if
      jpg-header
    else
      \ ."  byte out of header: " c@ .  1
      drop 1
    then
    dup 0= abort" end of jpeg image in jpg-dump ."
  +loop
  [ base ! ]
  ;
0 value jpg-searched  \ byte
: jpg-search  ( b -- )
  \ search a byte in the current jpeg file.
  \ this word was written to find out where the image width and height are stored.
  to jpg-searched  cr
  #jpg-buffer jpg-buffer + jpg-buffer
  do
    [char] . emit
    i c@ jpg-searched =
    if
      cr jpg-searched . ."  found at " i .
      i 16 - 32 .jpg-data
    then
  loop
  ;
0 value jpg-searched2 \ byte
defer jpg-found2
: (jpg-found2)  ( c-addr -- )
  \ default action after a successful search of two bytes.
  32 .jpg-data
  ;
' (jpg-found2) is jpg-found2
: jpg-search2  ( b1 b2 -- )
  \ Search the current JPEG file for two bytes.
  to jpg-searched2
  to jpg-searched  cr
  #jpg-buffer jpg-buffer + jpg-buffer
  do
    [char] . emit
    i c@ jpg-searched =
    i 1+ c@ jpg-searched2 = and
    if  jpg-found2  then
  loop
  ;
: jpg-search-xy  ( -- )
  \ Search and show any possible frame header in the current JPEG file.
  \ This word was written to find out why the size
  \ could not be found in pictures taken with a Nikon Coolpix 3100.
  [ base @ hex ]
  ' jpg-xy is jpg-found2
  ff c0 jpg-searched2
  ' (jpg-found2) is jpg-found2
  [ base ! ]
  ;

\ ---------------------------------------------
\ Testing

false [if]

: jpg-test  ( c-addr u -- )
  \ Test an image
  \ c-addr u = image file
  jpg-open
  jpg-dump
  jpg-close
  ;
: img1  s" c:\tmp\20071001153657_muestra.jpg"  ;
: img2  s" c:\tmp\alforja-saco\200709261743_alforjas_saco.jpg"  ;
: img3  s" c:\tmp\alforja-saco\200709261742_alforjas_saco.jpg"  ;
img1 jpg-test
img2 jpg-test
img3 jpg-test

[then]

.(  fjpg ok!)

Deŝutoj

fjpg.fs (7.47 KiB)