mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

resume in head table: bitfield

Browse Source
main
Matthew Butterick 8 years ago
parent a0d6aa449c
commit fe23713081
22 changed files with 325 additions and 111 deletions
Show Stats Download Patch File Download Diff File

2
pitfall/fontkit/bbox.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang pitfall/racket
#lang fontkit/racket
(provide BBox bbox->list)
(define-subclass object% (BBox

2
pitfall/fontkit/clone.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang racket
#lang fontkit/racket
(provide cloneDeep)
(define (cloneDeep val)

2
pitfall/fontkit/cmap-processor.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang pitfall/racket
#lang fontkit/racket
(provide CmapProcessor)
(define-subclass object% (CmapProcessor cmapTable)

73
pitfall/fontkit/directory.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang pitfall/racket
#lang fontkit/racket
(require restructure)
(provide (all-defined-out))
@ -32,40 +32,41 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js
(define is (make-object RDecodeStream ip))
(send Directory decode is))
(module+ test
(require rackunit racket/serialize)
(define ip (open-input-file "test/assets/Charter.ttf"))
(check-equal?
(directory-decode ip)
(deserialize '((3)
0
()
0
()
(test-module
(require racket/serialize)
(define ip (open-input-file charter-path))
(check-equal?
(directory-decode ip)
(deserialize '((3)
0
()
0
()
()
(h
!
()
(h
(tag u . "\u0000\u0001\u0000\u0000")
(rangeShift . 96)
(searchRange . 128)
(numTables . 14)
(entrySelector . 3)
(tables
h
!
()
(tag u . "\u0000\u0001\u0000\u0000")
(rangeShift . 96)
(searchRange . 128)
(numTables . 14)
(entrySelector . 3)
(tables
h
!
(equal)
(loca h ! () (tag u . "loca") (offset . 38692) (checkSum . 2795817194) (length . 460))
(glyf h ! () (tag u . "glyf") (offset . 4620) (checkSum . 1143629849) (length . 34072))
(OS/2 h ! () (tag u . "OS/2") (offset . 360) (checkSum . 2351070438) (length . 96))
(hhea h ! () (tag u . "hhea") (offset . 292) (checkSum . 132056097) (length . 36))
(post h ! () (tag u . "post") (offset . 41520) (checkSum . 1670855689) (length . 514))
(|cvt | h ! () (tag u . "cvt ") (offset . 4592) (checkSum . 10290865) (length . 26))
(VDMX h ! () (tag u . "VDMX") (offset . 1372) (checkSum . 1887795202) (length . 1504))
(prep h ! () (tag u . "prep") (offset . 4512) (checkSum . 490862356) (length . 78))
(maxp h ! () (tag u . "maxp") (offset . 328) (checkSum . 50135594) (length . 32))
(hmtx h ! () (tag u . "hmtx") (offset . 456) (checkSum . 3982043058) (length . 916))
(cmap h ! () (tag u . "cmap") (offset . 2876) (checkSum . 1723761408) (length . 1262))
(name h ! () (tag u . "name") (offset . 39152) (checkSum . 2629707307) (length . 2367))
(head h ! () (tag u . "head") (offset . 236) (checkSum . 4281190895) (length . 54))
(fpgm h ! () (tag u . "fpgm") (offset . 4140) (checkSum . 106535991) (length . 371))))))))
(equal)
(loca h ! () (tag u . "loca") (offset . 38692) (checkSum . 2795817194) (length . 460))
(glyf h ! () (tag u . "glyf") (offset . 4620) (checkSum . 1143629849) (length . 34072))
(OS/2 h ! () (tag u . "OS/2") (offset . 360) (checkSum . 2351070438) (length . 96))
(hhea h ! () (tag u . "hhea") (offset . 292) (checkSum . 132056097) (length . 36))
(post h ! () (tag u . "post") (offset . 41520) (checkSum . 1670855689) (length . 514))
(|cvt | h ! () (tag u . "cvt ") (offset . 4592) (checkSum . 10290865) (length . 26))
(VDMX h ! () (tag u . "VDMX") (offset . 1372) (checkSum . 1887795202) (length . 1504))
(prep h ! () (tag u . "prep") (offset . 4512) (checkSum . 490862356) (length . 78))
(maxp h ! () (tag u . "maxp") (offset . 328) (checkSum . 50135594) (length . 32))
(hmtx h ! () (tag u . "hmtx") (offset . 456) (checkSum . 3982043058) (length . 916))
(cmap h ! () (tag u . "cmap") (offset . 2876) (checkSum . 1723761408) (length . 1262))
(name h ! () (tag u . "name") (offset . 39152) (checkSum . 2629707307) (length . 2367))
(head h ! () (tag u . "head") (offset . 236) (checkSum . 4281190895) (length . 54))
(fpgm h ! () (tag u . "fpgm") (offset . 4140) (checkSum . 106535991) (length . 371))))))))

105
pitfall/fontkit/font.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang pitfall/racket
(require "freetype-ffi.rkt" ffi/unsafe racket/runtime-path "subset.rkt" "glyph.rkt" "layout-engine.rkt" "bbox.rkt" "glyphrun.rkt" "cmap-processor.rkt" "directory.rkt")
#lang fontkit/racket
(require "freetype-ffi.rkt" ffi/unsafe racket/runtime-path "subset.rkt" "glyph.rkt" "layout-engine.rkt" "bbox.rkt" "glyphrun.rkt" "cmap-processor.rkt" "directory.rkt" restructure/decodestream "tables.rkt")
(provide (all-defined-out))
(define-runtime-path charter-path "../pitfall/test/assets/charter.ttf")
@ -14,13 +14,12 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
(define-subclass object% (TTFFont stream)
(when stream (unless (input-port? stream)
(raise-argument-error 'TTFFont "input port" stream)))
(unless (member (bytes->string/latin-1 (peek-bytes 4 0 stream))
(list "true" "OTTO" "\u0\u1\u0\u0"))
(unless (member (peek-bytes 4 0 stream) (list #"true" #"OTTO" (bytes 0 1 0 0)))
(raise 'probe-fail))
(port-count-lines! stream)
;; skip variationCoords
(field [_directoryPos (port-position stream)]
[_tables (mhash)]
[_tables (mhash)] ; holds decoded tables (loaded lazily)
[_glyphs (mhash)]
[_layoutEngine #f])
@ -28,14 +27,17 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
(send this _decodeDirectory)
(define/public (_getTable table-tag)
(unless (hash-has-key? (hash-ref directory 'tables) table-tag)
(raise-argument-error '_getTable "table that exists" table-tag))
(hash-ref! _tables table-tag (_decodeTable table-tag))) ; load table from cache, decode if necessary
(define/public (_decodeTable table)
(report table '_decodeTable:starting)
(define-values (l c p) (port-next-location stream))
(set-port-next-location! stream l c p))
(unless (has-table? this table-tag)
(raise-argument-error '_getTable "table that exists in font" table-tag))
(hash-ref! _tables table-tag (_decodeTable table-tag))) ; get table from cache, load if not there
(define/public (_decodeTable table-tag)
(define table-decoder (hash-ref table-decoders table-tag
(λ () (raise-argument-error '_decodeTable "decodable table" table-tag))))
(define offset (· (hash-ref (· directory tables) table-tag) offset))
(define length (· (hash-ref (· directory tables) table-tag) length))
(set-port-position! stream offset)
(send table-decoder decode (make-object RDecodeStream stream) this length))
(define/public (_decodeDirectory)
(set! directory (directory-decode stream (mhash '_startOffset 0)))
@ -84,20 +86,19 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
;; The font’s [ascender](https://en.wikipedia.org/wiki/Ascender_(typography))
(define/contract (ascent this)
(->m number?)
(FT_FaceRec-ascender (· this ft-face)))
(hash-ref (send this _getTable 'hhea) 'ascent))
;; The font’s [descender](https://en.wikipedia.org/wiki/Descender)
(define/contract (descent this)
(->m number?)
(FT_FaceRec-descender (· this ft-face)))
(hash-ref (send this _getTable 'hhea) 'descent))
;; The amount of space that should be included between lines
(define/contract (lineGap this)
(->m number?)
(define hhea-table (cast (FT_Get_Sfnt_Table (· this ft-face) 'ft_sfnt_hhea) _pointer _FT_HoriHeader-pointer))
(FT_HoriHeader-lineGap hhea-table))
(hash-ref (send this _getTable 'hhea) 'lineGap))
(define/contract (underlinePosition this)
@ -143,11 +144,11 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
;; The font’s bounding box, i.e. the box that encloses all glyphs in the font.
(define/contract (bbox this)
(->m (is-a?/c BBox))
(let ([bbox (FT_FaceRec-bbox (· this ft-face))])
(make-object BBox (FT_BBox-xMin bbox)
(FT_BBox-yMin bbox)
(FT_BBox-xMax bbox)
(FT_BBox-yMax bbox))))
(define head-table (send this _getTable 'head))
(make-object BBox (· head-table xMin)
(· head-table yMin)
(· head-table xMax)
(· head-table yMax)))
(define/contract (_cmapProcessor this)
@ -164,16 +165,16 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
(define (has-table? this tag)
(FT_Load_Sfnt_Table (· this ft-face) (tag->int tag) 0 0 0))
(define/contract (has-table? this tag)
((or/c bytes? symbol?) . ->m . boolean?)
(hash-has-key? (· this directory tables) (if (bytes? tag)
(string->symbol (bytes->string/latin-1 tag))
tag)))
(define (has-cff-table? this) (has-table? this #"CFF "))
(define (has-morx-table? this) (has-table? this #"morx"))
(define (has-gpos-table? this) (has-table? this #"GPOS"))
(define (has-gsub-table? this) (has-table? this #"GSUB"))
(define has-cff-table? (curryr has-table? '|CFF |))
(define has-morx-table? (curryr has-table? 'morx))
(define has-gpos-table? (curryr has-table? 'GPOS))
(define has-gsub-table? (curryr has-table? 'GSUB))
;; Returns a glyph object for the given glyph id.
@ -262,23 +263,23 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
(error 'fontkit:create "unknown font format")))
(module+ test
(require rackunit)
(define f (openSync (path->string charter-path)))
(check-equal? (postscriptName f) "Charter")
(check-equal? (· f unitsPerEm) 1000)
(check-equal? (· f ascent) 980)
(check-equal? (· f descent) -238)
(check-equal? (measure-string f "f" (· f unitsPerEm)) 321.0)
(check-false (· f has-cff-table?))
(check-false (· f has-morx-table?))
(check-false (· f has-gsub-table?))
(check-false (· f has-gpos-table?))
(check-true (send f has-table? #"cmap"))
(check-equal? (· f lineGap) 0)
(check-exn exn:fail:contract? (λ () (send f _getTable 'nonexistent-table-tag)))
(send f _getTable 'maxp)
#;(· f createSubset)
)
(test-module
(define f (openSync (path->string charter-path)))
(check-equal? (postscriptName f) "Charter")
(check-equal? (· f unitsPerEm) 1000)
(check-equal? (· f ascent) 980)
(check-equal? (· f descent) -238)
(check-equal? (bbox->list (· f bbox)) '(-161 -236 1193 963))
(check-equal? (measure-string f "f" (· f unitsPerEm)) 321.0)
(check-false (· f has-cff-table?))
(check-false (· f has-morx-table?))
(check-false (· f has-gsub-table?))
(check-false (· f has-gpos-table?))
(check-true (send f has-table? #"cmap"))
(check-equal? (· f lineGap) 0)
(check-exn exn:fail:contract? (λ () (send f _getTable 'nonexistent-table-tag)))
#;(send f _getTable 'maxp)
(define subset (make-object TTFSubset f))
(send subset encode)
)

2
pitfall/fontkit/glyph-position.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang pitfall/racket
#lang fontkit/racket
(provide GlyphPosition)
;; Represents positioning information for a glyph in a GlyphRun.

2
pitfall/fontkit/glyph.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang pitfall/racket
#lang fontkit/racket
(require "freetype-ffi.rkt")
(provide Glyph CFFGlyph TTFGlyph)
(module+ test (require rackunit))

2
pitfall/fontkit/glyphrun.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang pitfall/racket
#lang fontkit/racket
(require "bbox.rkt" "script.rkt")
(provide GlyphRun)

52
pitfall/fontkit/head.rkt
Unescape Escape View File

@ -0,0 +1,52 @@
#lang fontkit/racket
(require restructure)
(provide (all-defined-out))
(define-subclass RStruct (Rhead))
(define head (make-object Rhead
(dictify
'version int32be ;; 0x00010000 (version 1.0)
'revision int32be ;; set by font manufacturer
'checkSumAdjustment uint32be
'magicNumber uint32be ;; set to 0x5F0F3CF5
'flags uint16be
'unitsPerEm uint16be ;; range from 64 to 16384
'created (make-object RArray int32be 2)
'modified (make-object RArray int32be 2)
'xMin int16be ;; for all glyph bounding boxes
'yMin int16be ;; for all glyph bounding boxes
'xMax int16be ;; for all glyph bounding boxes
'yMax int16be ;; for all glyph bounding boxes
'macStyle uint16be
#|
new Bitfield(uint16be [
' 'bold' 'italic' 'underline' 'outline'
' 'shadow' 'condensed' 'extended'
'])
|#
'lowestRecPPEM uint16be ;; smallest readable size in pixels
'fontDirectionHint int16be
'indexToLocFormat int16be ;; 0 for short offsets 1 for long
'glyphDataFormat int16be ;; 0 for current format
)))
(test-module
(require "directory.rkt")
(define ip (open-input-file charter-path))
(define dir (directory-decode ip))
(define offset (· dir tables head offset))
(define length (· dir tables head length))
(check-equal? offset 236)
(check-equal? length 54)
(define table-bytes #"\0\1\0\0\0\2\0\0@\247\22 _\17<\365\0\t\3\350\0\0\0\0\316\3\301?\0\0\0\0\316\3\304\363\377_\377\24\4\251\3\303\0\0\0\t\0\2\0\0\0\0")
(set-port-position! ip 0)
(check-equal? (peek-bytes length offset ip) table-bytes)
(define table-data (send head decode (make-object RDecodeStream table-bytes)))
(check-equal? (· table-data unitsPerEm) 1000)
(check-equal? (· table-data yMin) -236)
(check-equal? (· table-data yMax) 963)
(check-equal? (· table-data xMax) 1193)
(check-equal? (· table-data xMin) -161)
(check-equal? (· table-data magicNumber) #x5F0F3CF5))

12
pitfall/fontkit/helper.rkt
Unescape Escape View File

@ -0,0 +1,12 @@
#lang racket/base
(require (for-syntax racket/base) racket/runtime-path br/define)
(provide (all-defined-out))
(define index? (λ (x) (and (number? x) (integer? x) (not (negative? x)))))
(define-runtime-path charter-path "../pitfall/test/assets/Charter.ttf")
(define-macro (test-module . EXPRS)
#`(module+ test
(require #,(datum->syntax caller-stx 'rackunit))
. EXPRS))

39
pitfall/fontkit/hhea.rkt
Unescape Escape View File

@ -0,0 +1,39 @@
#lang fontkit/racket
(require restructure)
(provide (all-defined-out))
(define-subclass RStruct (Rhhea))
(define hhea (make-object Rhhea
(dictify
'version int32be
'ascent int16be ;; Distance from baseline of highest ascender
'descent int16be ;; Distance from baseline of lowest descender
'lineGap int16be ;; Typographic line gap
'advanceWidthMax uint16be ;; Maximum advance width value in 'hmtx' table
'minLeftSideBearing int16be ;; Maximum advance width value in 'hmtx' table
'minRightSideBearing int16be ;; Minimum right sidebearing value
'xMaxExtent int16be
'caretSlopeRise int16be ;; Used to calculate the slope of the cursor (rise/run); 1 for vertical
'caretSlopeRun int16be ;; 0 for vertical
'caretOffset int16be ;; Set to 0 for non-slanted fonts
'reserved (make-object RArray int16be 4)
'metricDataFormat int16be ;; 0 for current format
'numberOfMetrics uint16be ;; Number of advance widths in 'hmtx' table
)))
(test-module
(require "directory.rkt")
(define ip (open-input-file charter-path))
(define dir (directory-decode ip))
(define offset (· dir tables hhea offset))
(define length (· dir tables hhea length))
(check-equal? offset 292)
(check-equal? length 36)
(define table-bytes #"\0\1\0\0\3\324\377\22\0\0\4\311\377_\377`\4\251\0\1\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\345")
(set-port-position! ip 0)
(check-equal? (peek-bytes length offset ip) table-bytes)
(define table-data (send hhea decode (make-object RDecodeStream table-bytes)))
(check-equal? (· table-data ascent) 980)
(check-equal? (· table-data descent) -238))

2
pitfall/fontkit/layout-engine.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang pitfall/racket
#lang fontkit/racket
(require "script.rkt" "glyph.rkt" "glyphrun.rkt" "glyph-position.rkt")
(provide LayoutEngine)

2
pitfall/fontkit/main.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang restructure/racket
#lang fontkit/racket
(r+p "font.rkt"
"glyph-position.rkt"

39
pitfall/fontkit/maxp.rkt
Unescape Escape View File

@ -0,0 +1,39 @@
#lang fontkit/racket
(require restructure)
(provide (all-defined-out))
(define-subclass RStruct (Rmaxp))
(define maxp (make-object Rmaxp
(dictify 'version int32be
'numGlyphs uint16be ;; The number of glyphs in the font
'maxPoints uint16be ;; Maximum points in a non-composite glyph
'maxContours uint16be ;; Maximum contours in a non-composite glyph
'maxComponentPoints uint16be ;; Maximum points in a composite glyph
'maxComponentContours uint16be ;; Maximum contours in a composite glyph
'maxZones uint16be ;; 1 if instructions do not use the twilight zone, 2 otherwise
'maxTwilightPoints uint16be ;; Maximum points used in Z0
'maxStorage uint16be ;; Number of Storage Area locations
'maxFunctionDefs uint16be ;; Number of FDEFs
'maxInstructionDefs uint16be ;; Number of IDEFs
'maxStackElements uint16be ;; Maximum stack depth
'maxSizeOfInstructions uint16be ;; Maximum byte count for glyph instructions
'maxComponentElements uint16be ;; Maximum number of components referenced at “top level” for any composite glyph
'maxComponentDepth uint16be ;; Maximum levels of recursion; 1 for simple components
)))
(test-module
(require "directory.rkt")
(define ip (open-input-file charter-path))
(define dir (directory-decode ip))
(define maxp-offset (· dir tables maxp offset))
(define maxp-length (· dir tables maxp length))
(check-equal? maxp-offset 328)
(check-equal? maxp-length 32)
(define maxp-bytes #"\0\1\0\0\0\345\0f\0\a\0O\0\4\0\1\0\0\0\0\0\n\0\0\2\0\1s\0\2\0\1")
(set-port-position! ip 0)
(check-equal? (peek-bytes maxp-length maxp-offset ip) maxp-bytes)
(define maxp-data (send maxp decode (make-object RDecodeStream maxp-bytes)))
(check-equal? (· maxp-data numGlyphs) 229)
(check-equal? (· maxp-data version) 65536))

30
pitfall/fontkit/racket.rkt
Unescape Escape View File

@ -0,0 +1,30 @@
#lang racket/base
(require (for-syntax racket/base br/syntax))
(provide (for-syntax (all-from-out racket/base br/syntax)))
(provide (all-from-out racket/base) r+p)
(define-syntax-rule (r+p id ...) (begin (require id ...) (provide (all-from-out id ...))))
(r+p "helper.rkt"
sugar/debug
racket/class
racket/file
racket/match
racket/string
racket/format
racket/contract
racket/list
racket/port
racket/function
br/define
sugar/class
sugar/js
sugar/dict
sugar/stub
sugar/port)
(module reader syntax/module-reader
#:language 'fontkit/racket
#:read @-read
#:read-syntax @-read-syntax
(require (prefix-in @- scribble/reader)))

2
pitfall/fontkit/script.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang pitfall/racket
#lang fontkit/racket
(provide (all-defined-out))
;; approximates

22
pitfall/fontkit/subset.rkt
Unescape Escape View File

@ -1,9 +1,11 @@
#lang pitfall/racket
#lang fontkit/racket
(require "clone.rkt" "ttfglyphencoder.rkt")
(provide Subset CFFSubset TTFSubset)
;; approximates
;; https://github.com/devongovett/fontkit/blob/master/src/subset/Subset.js
#|
approximates
https://github.com/devongovett/fontkit/blob/master/src/subset/Subset.js
|#
(define-subclass object% (Subset font)
(field [glyphs empty] ; list of glyph ids in the subset
@ -67,8 +69,20 @@ https://github.com/mbutterick/fontkit/blob/master/src/subset/TTFSubset.js
(for ([gid (in-list (· this glyphs))])
(send this _addGlyph gid))
(define maxp (cloneDeep (send (· this font) _getTable maxp)))
(define maxp (cloneDeep (send (· this font) _getTable 'maxp)))
;; (hash-set! maxp 'numGlyphs (length (· this glyf))) ; todo
;; todo
;; this.loca.offsets.push(this.offset);
;; Tables.loca.preEncode.call(this.loca);
(define head (cloneDeep (send (· this font) _getTable 'head)))
;; head.indexToLocFormat = this.loca.version; ; todo
(define hhea (cloneDeep (send (· this font) _getTable 'hhea)))
;; hhea.numberOfMetrics = this.hmtx.metrics.length;
(unfinished)
)

11
pitfall/fontkit/tables.rkt
Unescape Escape View File

@ -0,0 +1,11 @@
#lang fontkit/racket
(provide (all-defined-out))
(define-macro (define-table-decoders ID TABLE-ID ...)
(with-pattern ([TABLE-ID-STRINGS (pattern-case-filter #'(TABLE-ID ...)
[STX (datum->syntax caller-stx (format "~a.rkt" (syntax->datum #'STX)))])])
#'(begin
(r+p . TABLE-ID-STRINGS)
(define ID (make-hasheq (map cons (list 'TABLE-ID ...) (list TABLE-ID ...)))))))
(define-table-decoders table-decoders maxp hhea head)

2
pitfall/fontkit/ttfglyphencoder.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang pitfall/racket
#lang fontkit/racket
(provide TTFGlyphEncoder)
(define-subclass object% (TTFGlyphEncoder)

2
pitfall/pitfall/helper.rkt
Unescape Escape View File

@ -25,7 +25,7 @@
(define (layout? x)
(and (hash? x) (hash-has-key? x 'glyphs) (hash-has-key? x 'positions)))
(define index? (and/c (not/c negative?) integer?))
(define index? (and/c number? integer? (not/c negative?)))

10
pitfall/restructure/decodestream.rkt
Unescape Escape View File

@ -24,14 +24,12 @@
[endian '("" BE LE)])
(values (string->symbol (format "~a~a" key endian)) value))))
(require racket/port)
;; basically just a wrapper for a Racket port
(define-subclass object% (RDecodeStream [buffer-in #""])
(field [buffer (if (input-port? buffer-in)
(port->bytes buffer-in)
buffer-in)]
[length (bytes-length buffer)]
[_port (open-input-bytes buffer)])
(field [_port (cond
[(bytes? buffer-in) (open-input-bytes buffer-in)]
[(input-port? buffer-in) buffer-in]
[else (raise-argument-error 'RDecodeStream "bytes or input port" buffer-in)])])
(getter-field [pos (port-position _port)])
(define/public (read count)

21
pitfall/sugar/port.rkt
Unescape Escape View File

@ -3,5 +3,22 @@
(provide (all-defined-out) (all-from-out racket/port))
(define (port-position ip)
(define-values (line col pos) (port-next-location ip))
pos)
(file-position ip))
(define (set-port-position! ip where)
(file-position ip where))
(module+ test
(require rackunit)
(define ip (open-input-bytes (bytes 1 2 3 4)))
(port-count-lines! ip)
(check-equal? (port-position ip) 0)
(check-equal? (read-byte ip) 1)
(check-equal? (port-position ip) 1)
(check-equal? (read-byte ip) 2)
(set-port-position! ip 4)
(check-equal? (port-position ip) 4)
(check-equal? (read-byte ip) eof)
(set-port-position! ip 0)
(check-equal? (port-position ip) 0)
(check-equal? (read-byte ip) 1))
Write Preview
Loading…
Cancel
Save