[openfirmware] r1716 - cpu/x86/pc/olpc/via
svn at openfirmware.info
svn at openfirmware.info
Thu Jan 28 14:59:56 CET 2010
Author: rsmith
Date: 2010-01-28 14:59:56 +0100 (Thu, 28 Jan 2010)
New Revision: 1716
Added:
cpu/x86/pc/olpc/via/final.fth
Removed:
cpu/x86/pc/olpc/via/runin.fth
Log:
Rename runin.fth to final.fth
Copied: cpu/x86/pc/olpc/via/final.fth (from rev 1714, cpu/x86/pc/olpc/via/runin.fth)
===================================================================
--- cpu/x86/pc/olpc/via/final.fth (rev 0)
+++ cpu/x86/pc/olpc/via/final.fth 2010-01-28 13:59:56 UTC (rev 1716)
@@ -0,0 +1,465 @@
+\ Post-runin boot script $Revision$
+
+visible
+
+\ Location of the files containing KA tag data
+: ka-dir$ ( -- adr len ) " http:\\10.1.0.1\ka\" ;
+
+: mfg-ntp-server ( -- name$ )
+ " NT" find-tag if ?-null else " 10.1.0.1" then
+;
+' mfg-ntp-server to ntp-servers
+
+\ The Linux-based runin selftests put this file at int:\runin\olpc.fth
+\ after they have finished. On the next reboot, OFW thus boots this
+\ script instead of int:\boot\olpc.fth . This script either displays
+\ the failure log (if int:\runin\fail.log is present) or modifies the
+\ manufacturing data tags to cause the next boot to enter final test.
+
+d# 128 buffer: mb-buf : mb$ mb-buf count ;
+
+: get-mb-tags ( -- )
+ " B#" find-tag if
+ ?-null
+ then
+ mb-buf place
+;
+
+: set-tag-assy ( -- )
+ get-mb-tags
+
+ clear-mfg-buf
+
+ " " " ww" put-ascii-tag
+
+ " "(D3)" " SG" ($add-tag)
+ mb$ " B#" put-ascii-tag
+ " EN" " SS" put-ascii-tag
+
+ " ASSY" " TS" put-ascii-tag
+ " cifs:\\Administrator:qmsswdl at 10.0.0.2\OLPC_TM" " MS" put-ascii-tag
+ " u:\boot\olpc.fth net" " BD" put-ascii-tag
+
+ flash-write-enable
+ (put-mfg-data)
+ no-kbc-reboot
+ kbc-on
+;
+
+d# 20 buffer: sn-buf
+: sn$ ( -- adr len ) sn-buf count ;
+
+: try-scan-sn ( -- gotit? )
+ sn-buf 1+ d# 20 accept ( n )
+ d# 12 <> if
+ " Wrong length, try again" .problem
+ false exit
+ then
+ sn-buf 1+ " TSHC" comp if
+ " Must begin with TSHC, try again" .problem
+ false exit
+ then
+ sn-buf 2+ sn-buf 1+ d# 11 move \ Elide the T
+ d# 11 sn-buf c!
+ true
+;
+
+: scan-sn ( -- )
+ ." *****"
+
+ begin
+ " Please Input Serial Number ......" .instructions
+ try-scan-sn
+ until
+;
+
+: board#$ ( -- adr len )
+ " B#" find-tag 0= abort" Missing B# tag !!!"
+ -null
+;
+
+: get-sn-value ( --)
+ " SN" find-tag if
+ ?-null
+ else
+ abort" Missing SN tag !!!"
+ then
+ sn-buf place
+;
+
+0 0 2value response$
+
+: final-filename$ ( -- adr len ) sn$ " %s.txt" sprintf ;
+
+: check-err-msg ( adr len -- )
+ begin dup while ( adr len )
+ linefeed left-parse-string ( rem$ line$ )
+ ?remove-cr ( rem$ line$ )
+ [char] : left-parse-string ( rem$ value$ key$ )
+ " ERR_MSG" $= if ( rem$ value$ )
+ page show-fail
+ type ( rem$ )
+ cr cr
+ ." Perss any key to power off!"
+ key drop cr cr
+ power-off
+ then ( rem$ value$ )
+ 2drop ( rem$ )
+ repeat ( rem$ )
+ 2drop ( )
+;
+
+\ Send the board number as the request and return the response data
+: final-tag-exchange ( -- )
+ final-filename$ open-temp-file
+ sn$ " SN:" put-key+value
+ " Request" submit-file
+ " Response" get-response to response$
+ response$ check-err-msg
+;
+
+: show-result-screen ( -- )
+ pass? if
+ clear-screen
+ ." PASS" cr cr
+ green-screen
+ else
+ ." FAIL" cr cr
+ set-tag-assy
+ red-screen
+ then
+;
+
+: put-ka-tag ( value$ key$ -- )
+ 2over 8 min ka-dir$ " %s%s" sprintf ( value$ key$ filename$ )
+ $read-file if ( value$ key$ )
+ ." ERROR: No KA tag file for " 2swap type cr ( key$ )
+ true abort" KA file not found" ( key$ )
+ 2drop ( )
+ else ( value$ key$ file-data$ )
+ 2swap ($add-tag) ( value$ )
+ 2drop ( )
+ then
+;
+
+false value write-protect?
+
+: special-tag? ( value$ key$ -- true | value$ key$ false )
+ 2dup " KA" $= if ( value$ key$ )
+ put-ka-tag ( )
+ true exit ( -- true )
+ then ( value$ key$ )
+ 2dup " WP" nocase-$= if ( value$ key$ )
+ 2drop " 0" $= 0= to write-protect? ( )
+ true exit ( -- true )
+ then ( value$ key$ )
+ 2dup " ak" nocase-$= if ( value$ key$ )
+ 2drop " 0" $= 0= if ( )
+ " " " ak" ($add-tag) ( )
+ then ( )
+ true exit ( -- true )
+ then ( value$ key$ )
+ false ( value$ key$ false )
+;
+: put-tag ( value$ key$ -- )
+ special-tag? if exit then
+ put-ascii-tag
+;
+: show-tag ( value$ -- )
+ 2dup $tag-printable? if ?-null type else wrapped-cdump then
+;
+: do-tag-error ( -- )
+ ." Problem with tag processing. Halting." cr
+ begin halt again
+;
+: handle-tag ( value$ key$ -- )
+ 2dup ram-find-tag if ( value$ key$ old-value$ ) \ Tag already exists, check it
+ 2over " KA" $= 0= if ?-null then ( value$ key$ old-value$' )
+ 2>r 2over 2r@ $= if ( value$ key$ r: old-value$' )
+ 2drop 2drop 2r> 2drop ( )
+ else ( value$ key$ r: old-value$' )
+ type ." tag changed!" cr ( value$ r: old-value$' )
+ ." Old: " 2r> show-tag cr ( value$ )
+ ." New: " show-tag cr ( )
+ do-tag-error
+ then
+ else ( value$ key$ ) \ New tag, add it
+ put-tag
+ then
+;
+
+: replace-ka-value ( rem$ value$ key$ -- rem$ file-data$ key$ )
+ 2swap 2dup 8 min ka-dir$ " %s%s" sprintf ( rem$ key$ value$ filename$ )
+ $read-file if ( rem$ key$ value$ )
+ ." ERROR: No KA tag file for " type cr ( rem$ key$ )
+ true abort" KA file not found" ( rem$ key$ )
+ 2drop ( rem$ )
+ else ( rem$ key$ value$ file-data$ )
+ 2swap 2drop ( rem$ key$ file-data$ )
+ 2swap ( rem$ file-data$ key$ )
+ then
+;
+
+: parse-tags ( adr len -- )
+ begin dup while ( adr len )
+ linefeed left-parse-string ( rem$ line$ )
+ ?remove-cr ( rem$ line$ )
+ [char] : left-parse-string ( rem$ value$ key$ )
+ dup 2 = if ( rem$ value$ key$ )
+ \ catch value from http, if KA tag
+ 2dup " KA" $= if ( rem$ value$ key$ )
+ replace-ka-value ( rem$ value$' key$ )
+ then
+ handle-tag ( rem$ )
+ else ( rem$ value$ key$ )
+ 4drop ( rem$ )
+ then ( rem$ )
+ repeat ( adr len )
+ 2drop ( )
+;
+
+: format-date ( s m h d m y -- adr len )
+ push-decimal
+ >r >r >r >r >r >r
+ <#
+ [char] Z hold
+ r> u# u# drop
+ r> u# u# drop
+ r> u# u# drop
+ [char] T hold
+ r> u# u# drop
+ r> u# u# drop
+ r> u# u# u# u#
+ u#>
+ pop-base
+;
+: make-md-tag ( -- )
+ time&date ( s m h d m y ) format-date " md" put-ascii-tag
+;
+: inject-tags ( -- )
+ get-mfg-data
+
+ " TS" ($delete-tag)
+ " MS" ($delete-tag)
+ " BD" ($delete-tag)
+ " NT" ($delete-tag)
+ " MD" ($delete-tag)
+ " Pr" ($delete-tag)
+ make-md-tag
+
+ response$ parse-tags
+
+ " TS" ($delete-tag)
+ " SHIP" " TS" put-ascii-tag
+
+ flash-write-enable
+ (put-mfg-data)
+ \ Change "ww" to "wp" if we want security to be enabled
+ write-protect? if " wp" h# efffe write-spi-flash then
+ no-kbc-reboot
+ kbc-on
+;
+
+d# 180 constant rtc-threshold \ yes, really. 3 minutes
+0 value ntp-seconds
+0 value rtc-seconds
+: .clocks ( -- )
+ ." RTC: " rtc-seconds unix-seconds> .date space .time ." UTC" cr
+ ." NTP: " ntp-seconds unix-seconds> .date space .time ." UTC" cr
+;
+: verify-rtc-date ( -- )
+\ XXX check RTC power lost bit
+ ." Getting time from NTP server .. "
+ begin ntp-timestamp while ." Retry " repeat ( d.timestamp )
+
+ ntp>time&date >unix-seconds to ntp-seconds
+ time&date >unix-seconds to rtc-seconds
+ ntp-seconds rtc-seconds - ( lost-seconds )
+ dup rtc-threshold > if ( lost-seconds )
+ page show-fail ( lost-seconds )
+ ." Clock lost " .d ." seconds since SMT" cr ( )
+ .clocks
+ stall
+ then ( lost-seconds )
+
+ abs dup rtc-threshold > if ( gained-seconds )
+ page show-fail ( gained-seconds )
+ ." Clock gained " .d ." seconds since SMT" cr ( )
+ .clocks
+ stall
+ then
+ ." NTP and RTC clocks agree." cr
+;
+
+: put-key:value ( value$ key$ -- ) " %s:%s" sprintf put-key-line ;
+
+: upload-tag ( data$ tag$ -- )
+ 2dup " wp" $= if ( data$ tag$ )
+ 4drop " 1" " WP" put-key:value ( )
+ exit
+ then
+ 2dup " ww" $= if ( data$ tag$ )
+ 4drop " 0" " WP" put-key:value ( )
+ exit
+ then
+ 2dup " ak" $= if ( data$ tag$ )
+ 4drop " 1" " ak" put-key:value ( )
+ exit
+ then
+ 2dup " KA" $= if ( data$ tag$ )
+ 4drop ( )
+ exit
+ then
+ 2dup " SG" $= if ( data$ tag$ )
+ 4drop ( )
+ exit
+ then ( data$ tag$ )
+
+ 2swap ?-null 2swap ( data$' tag$ )
+ put-key:value ( )
+;
+
+: upload-tags ( -- )
+ mfg-data-top ( adr )
+ begin another-tag? while ( adr' data$ tname-adr )
+ 2 upload-tag ( adr )
+ repeat ( adr )
+ drop
+;
+
+\ Upload the result data
+: final-result ( -- )
+ final-filename$ open-temp-file
+ upload-tags
+ pass? if " PASS" else " FAIL" then " RESULT=" put-key+value
+ " Handshake" submit-file
+;
+
+: wait-connections ( -- )
+ silent-probe-usb
+ wait-lan
+;
+
+: my-cifs-connect ( adr -- )
+ open-dev to cifs-ih
+ cifs-ih 0= abort" Cannot open SMB share"
+;
+
+\ $rename gives "Unimplemented package interface procedure" on ext2
+: do-rename
+ 2>r 2dup 2r> $copy $delete
+;
+
+: $safe-delete ( $name -- )
+ 2dup $file-exists? if
+ 2dup $delete
+ then
+ 2drop
+;
+
+: $copy! ( $src $dst -- )
+ 2dup $file-exists? if
+ 2dup $delete
+ then
+ $copy1
+;
+
+
+: finish-final-test ( -- )
+
+ " int:\runin\final.fth" $safe-delete
+ " int:\runin\repass.fth" 2dup $file-exists? if
+ " int:\runin\final.fth" $copy
+ else
+ 2drop
+ then
+
+ wait-connections
+
+ get-sn-value
+
+ verify-rtc-date
+
+ ." Getting final tags .. "
+ cifs-connect final-tag-exchange \ Note: no disconnect...
+ ." Done" cr
+
+ inject-tags
+
+ ." Submitting results .. "
+ final-result cifs-disconnect
+ ." Done" cr
+
+ " int:\runin\repass.fth" $safe-delete
+
+ \ need to delete target, due to #9957
+ " int:\runin\final.fth.sav" $safe-delete
+
+ " int:\runin\final.fth" " int:\runin\final.fth.sav" $rename
+;
+
+\ Make the "wait for SD insertion" step highly visible
+dev ext
+warning @ warning off
+: wait&clear ( -- error? ) wait-card? page ;
+patch wait&clear wait-card? selftest
+: selftest ( -- ) page show-pass selftest ;
+warning !
+dend
+
+: fail-backup-file$ ( -- name$ )
+ time&date format-date " int:\runin\fail-%s.log" sprintf
+;
+: fail-log-file$ ( -- name$ ) " int:\runin\fail.log" ;
+
+\ The operator can type this to reset the state to run
+\ the Linux-based runin tests again.
+: rerunin ( -- )
+ " int:\runin\final.fth" $safe-delete
+ fail-log-file$ fail-backup-file$ do-rename
+;
+
+: after-runin ( -- )
+ fail-log-file$ $read-file 0= if ( adr len )
+ page
+ show-fail
+ ." Type a key to see the failure log"
+ key drop cr cr
+ list
+ ." Type R to restart runin, any other key to power off "
+ key dup emit cr upc [char] R = if
+ ." Resetting state to restart runin." cr
+ ." The old failure log is in " fail-backup-file$ type cr
+ rerunin
+ else
+ power-off
+ then
+ else
+ autorun-mfg-tests
+ pass? if finish-final-test then
+ show-result-screen
+ then
+
+ ." Type a key to power off"
+ key cr
+ power-off
+;
+
+\ Override the display self test
+dev /display
+
+warning @ warning off
+: selftest ( -- error? )
+ depth d# 16 < if false exit then
+
+ .vertical-bars16 wait
+ hgradient
+
+ confirm-selftest?
+;
+warning !
+
+device-end
+
+." Starting final phase" cr
+after-runin
Deleted: cpu/x86/pc/olpc/via/runin.fth
===================================================================
--- cpu/x86/pc/olpc/via/runin.fth 2010-01-28 02:44:36 UTC (rev 1715)
+++ cpu/x86/pc/olpc/via/runin.fth 2010-01-28 13:59:56 UTC (rev 1716)
@@ -1,465 +0,0 @@
-\ Post-runin boot script $Revision$
-
-visible
-
-\ Location of the files containing KA tag data
-: ka-dir$ ( -- adr len ) " http:\\10.1.0.1\ka\" ;
-
-: mfg-ntp-server ( -- name$ )
- " NT" find-tag if ?-null else " 10.1.0.1" then
-;
-' mfg-ntp-server to ntp-servers
-
-\ The Linux-based runin selftests put this file at int:\runin\olpc.fth
-\ after they have finished. On the next reboot, OFW thus boots this
-\ script instead of int:\boot\olpc.fth . This script either displays
-\ the failure log (if int:\runin\fail.log is present) or modifies the
-\ manufacturing data tags to cause the next boot to enter final test.
-
-d# 128 buffer: mb-buf : mb$ mb-buf count ;
-
-: get-mb-tags ( -- )
- " B#" find-tag if
- ?-null
- then
- mb-buf place
-;
-
-: set-tag-assy ( -- )
- get-mb-tags
-
- clear-mfg-buf
-
- " " " ww" put-ascii-tag
-
- " "(D3)" " SG" ($add-tag)
- mb$ " B#" put-ascii-tag
- " EN" " SS" put-ascii-tag
-
- " ASSY" " TS" put-ascii-tag
- " cifs:\\Administrator:qmsswdl at 10.0.0.2\OLPC_TM" " MS" put-ascii-tag
- " u:\boot\olpc.fth net" " BD" put-ascii-tag
-
- flash-write-enable
- (put-mfg-data)
- no-kbc-reboot
- kbc-on
-;
-
-d# 20 buffer: sn-buf
-: sn$ ( -- adr len ) sn-buf count ;
-
-: try-scan-sn ( -- gotit? )
- sn-buf 1+ d# 20 accept ( n )
- d# 12 <> if
- " Wrong length, try again" .problem
- false exit
- then
- sn-buf 1+ " TSHC" comp if
- " Must begin with TSHC, try again" .problem
- false exit
- then
- sn-buf 2+ sn-buf 1+ d# 11 move \ Elide the T
- d# 11 sn-buf c!
- true
-;
-
-: scan-sn ( -- )
- ." *****"
-
- begin
- " Please Input Serial Number ......" .instructions
- try-scan-sn
- until
-;
-
-: board#$ ( -- adr len )
- " B#" find-tag 0= abort" Missing B# tag !!!"
- -null
-;
-
-: get-sn-value ( --)
- " SN" find-tag if
- ?-null
- else
- abort" Missing SN tag !!!"
- then
- sn-buf place
-;
-
-0 0 2value response$
-
-: final-filename$ ( -- adr len ) sn$ " %s.txt" sprintf ;
-
-: check-err-msg ( adr len -- )
- begin dup while ( adr len )
- linefeed left-parse-string ( rem$ line$ )
- ?remove-cr ( rem$ line$ )
- [char] : left-parse-string ( rem$ value$ key$ )
- " ERR_MSG" $= if ( rem$ value$ )
- page show-fail
- type ( rem$ )
- cr cr
- ." Perss any key to power off!"
- key drop cr cr
- power-off
- then ( rem$ value$ )
- 2drop ( rem$ )
- repeat ( rem$ )
- 2drop ( )
-;
-
-\ Send the board number as the request and return the response data
-: final-tag-exchange ( -- )
- final-filename$ open-temp-file
- sn$ " SN:" put-key+value
- " Request" submit-file
- " Response" get-response to response$
- response$ check-err-msg
-;
-
-: show-result-screen ( -- )
- pass? if
- clear-screen
- ." PASS" cr cr
- green-screen
- else
- ." FAIL" cr cr
- set-tag-assy
- red-screen
- then
-;
-
-: put-ka-tag ( value$ key$ -- )
- 2over 8 min ka-dir$ " %s%s" sprintf ( value$ key$ filename$ )
- $read-file if ( value$ key$ )
- ." ERROR: No KA tag file for " 2swap type cr ( key$ )
- true abort" KA file not found" ( key$ )
- 2drop ( )
- else ( value$ key$ file-data$ )
- 2swap ($add-tag) ( value$ )
- 2drop ( )
- then
-;
-
-false value write-protect?
-
-: special-tag? ( value$ key$ -- true | value$ key$ false )
- 2dup " KA" $= if ( value$ key$ )
- put-ka-tag ( )
- true exit ( -- true )
- then ( value$ key$ )
- 2dup " WP" nocase-$= if ( value$ key$ )
- 2drop " 0" $= 0= to write-protect? ( )
- true exit ( -- true )
- then ( value$ key$ )
- 2dup " ak" nocase-$= if ( value$ key$ )
- 2drop " 0" $= 0= if ( )
- " " " ak" ($add-tag) ( )
- then ( )
- true exit ( -- true )
- then ( value$ key$ )
- false ( value$ key$ false )
-;
-: put-tag ( value$ key$ -- )
- special-tag? if exit then
- put-ascii-tag
-;
-: show-tag ( value$ -- )
- 2dup $tag-printable? if ?-null type else wrapped-cdump then
-;
-: do-tag-error ( -- )
- ." Problem with tag processing. Halting." cr
- begin halt again
-;
-: handle-tag ( value$ key$ -- )
- 2dup ram-find-tag if ( value$ key$ old-value$ ) \ Tag already exists, check it
- 2over " KA" $= 0= if ?-null then ( value$ key$ old-value$' )
- 2>r 2over 2r@ $= if ( value$ key$ r: old-value$' )
- 2drop 2drop 2r> 2drop ( )
- else ( value$ key$ r: old-value$' )
- type ." tag changed!" cr ( value$ r: old-value$' )
- ." Old: " 2r> show-tag cr ( value$ )
- ." New: " show-tag cr ( )
- do-tag-error
- then
- else ( value$ key$ ) \ New tag, add it
- put-tag
- then
-;
-
-: replace-ka-value ( rem$ value$ key$ -- rem$ file-data$ key$ )
- 2swap 2dup 8 min ka-dir$ " %s%s" sprintf ( rem$ key$ value$ filename$ )
- $read-file if ( rem$ key$ value$ )
- ." ERROR: No KA tag file for " type cr ( rem$ key$ )
- true abort" KA file not found" ( rem$ key$ )
- 2drop ( rem$ )
- else ( rem$ key$ value$ file-data$ )
- 2swap 2drop ( rem$ key$ file-data$ )
- 2swap ( rem$ file-data$ key$ )
- then
-;
-
-: parse-tags ( adr len -- )
- begin dup while ( adr len )
- linefeed left-parse-string ( rem$ line$ )
- ?remove-cr ( rem$ line$ )
- [char] : left-parse-string ( rem$ value$ key$ )
- dup 2 = if ( rem$ value$ key$ )
- \ catch value from http, if KA tag
- 2dup " KA" $= if ( rem$ value$ key$ )
- replace-ka-value ( rem$ value$' key$ )
- then
- handle-tag ( rem$ )
- else ( rem$ value$ key$ )
- 4drop ( rem$ )
- then ( rem$ )
- repeat ( adr len )
- 2drop ( )
-;
-
-: format-date ( s m h d m y -- adr len )
- push-decimal
- >r >r >r >r >r >r
- <#
- [char] Z hold
- r> u# u# drop
- r> u# u# drop
- r> u# u# drop
- [char] T hold
- r> u# u# drop
- r> u# u# drop
- r> u# u# u# u#
- u#>
- pop-base
-;
-: make-md-tag ( -- )
- time&date ( s m h d m y ) format-date " md" put-ascii-tag
-;
-: inject-tags ( -- )
- get-mfg-data
-
- " TS" ($delete-tag)
- " MS" ($delete-tag)
- " BD" ($delete-tag)
- " NT" ($delete-tag)
- " MD" ($delete-tag)
- " Pr" ($delete-tag)
- make-md-tag
-
- response$ parse-tags
-
- " TS" ($delete-tag)
- " SHIP" " TS" put-ascii-tag
-
- flash-write-enable
- (put-mfg-data)
- \ Change "ww" to "wp" if we want security to be enabled
- write-protect? if " wp" h# efffe write-spi-flash then
- no-kbc-reboot
- kbc-on
-;
-
-d# 180 constant rtc-threshold \ yes, really. 3 minutes
-0 value ntp-seconds
-0 value rtc-seconds
-: .clocks ( -- )
- ." RTC: " rtc-seconds unix-seconds> .date space .time ." UTC" cr
- ." NTP: " ntp-seconds unix-seconds> .date space .time ." UTC" cr
-;
-: verify-rtc-date ( -- )
-\ XXX check RTC power lost bit
- ." Getting time from NTP server .. "
- begin ntp-timestamp while ." Retry " repeat ( d.timestamp )
-
- ntp>time&date >unix-seconds to ntp-seconds
- time&date >unix-seconds to rtc-seconds
- ntp-seconds rtc-seconds - ( lost-seconds )
- dup rtc-threshold > if ( lost-seconds )
- page show-fail ( lost-seconds )
- ." Clock lost " .d ." seconds since SMT" cr ( )
- .clocks
- stall
- then ( lost-seconds )
-
- abs dup rtc-threshold > if ( gained-seconds )
- page show-fail ( gained-seconds )
- ." Clock gained " .d ." seconds since SMT" cr ( )
- .clocks
- stall
- then
- ." NTP and RTC clocks agree." cr
-;
-
-: put-key:value ( value$ key$ -- ) " %s:%s" sprintf put-key-line ;
-
-: upload-tag ( data$ tag$ -- )
- 2dup " wp" $= if ( data$ tag$ )
- 4drop " 1" " WP" put-key:value ( )
- exit
- then
- 2dup " ww" $= if ( data$ tag$ )
- 4drop " 0" " WP" put-key:value ( )
- exit
- then
- 2dup " ak" $= if ( data$ tag$ )
- 4drop " 1" " ak" put-key:value ( )
- exit
- then
- 2dup " KA" $= if ( data$ tag$ )
- 4drop ( )
- exit
- then
- 2dup " SG" $= if ( data$ tag$ )
- 4drop ( )
- exit
- then ( data$ tag$ )
-
- 2swap ?-null 2swap ( data$' tag$ )
- put-key:value ( )
-;
-
-: upload-tags ( -- )
- mfg-data-top ( adr )
- begin another-tag? while ( adr' data$ tname-adr )
- 2 upload-tag ( adr )
- repeat ( adr )
- drop
-;
-
-\ Upload the result data
-: final-result ( -- )
- final-filename$ open-temp-file
- upload-tags
- pass? if " PASS" else " FAIL" then " RESULT=" put-key+value
- " Handshake" submit-file
-;
-
-: wait-connections ( -- )
- silent-probe-usb
- wait-lan
-;
-
-: my-cifs-connect ( adr -- )
- open-dev to cifs-ih
- cifs-ih 0= abort" Cannot open SMB share"
-;
-
-\ $rename gives "Unimplemented package interface procedure" on ext2
-: do-rename
- 2>r 2dup 2r> $copy $delete
-;
-
-: $safe-delete ( $name -- )
- 2dup $file-exists? if
- 2dup $delete
- then
- 2drop
-;
-
-: $copy! ( $src $dst -- )
- 2dup $file-exists? if
- 2dup $delete
- then
- $copy1
-;
-
-
-: finish-final-test ( -- )
-
- " int:\runin\final.fth" $safe-delete
- " int:\runin\repass.fth" 2dup $file-exists? if
- " int:\runin\final.fth" $copy
- else
- 2drop
- then
-
- wait-connections
-
- get-sn-value
-
- verify-rtc-date
-
- ." Getting final tags .. "
- cifs-connect final-tag-exchange \ Note: no disconnect...
- ." Done" cr
-
- inject-tags
-
- ." Submitting results .. "
- final-result cifs-disconnect
- ." Done" cr
-
- " int:\runin\repass.fth" $safe-delete
-
- \ need to delete target, due to #9957
- " int:\runin\final.fth.sav" $safe-delete
-
- " int:\runin\final.fth" " int:\runin\final.fth.sav" $rename
-;
-
-\ Make the "wait for SD insertion" step highly visible
-dev ext
-warning @ warning off
-: wait&clear ( -- error? ) wait-card? page ;
-patch wait&clear wait-card? selftest
-: selftest ( -- ) page show-pass selftest ;
-warning !
-dend
-
-: fail-backup-file$ ( -- name$ )
- time&date format-date " int:\runin\fail-%s.log" sprintf
-;
-: fail-log-file$ ( -- name$ ) " int:\runin\fail.log" ;
-
-\ The operator can type this to reset the state to run
-\ the Linux-based runin tests again.
-: rerunin ( -- )
- " int:\runin\final.fth" $safe-delete
- fail-log-file$ fail-backup-file$ do-rename
-;
-
-: after-runin ( -- )
- fail-log-file$ $read-file 0= if ( adr len )
- page
- show-fail
- ." Type a key to see the failure log"
- key drop cr cr
- list
- ." Type R to restart runin, any other key to power off "
- key dup emit cr upc [char] R = if
- ." Resetting state to restart runin." cr
- ." The old failure log is in " fail-backup-file$ type cr
- rerunin
- else
- power-off
- then
- else
- autorun-mfg-tests
- pass? if finish-final-test then
- show-result-screen
- then
-
- ." Type a key to power off"
- key cr
- power-off
-;
-
-\ Override the display self test
-dev /display
-
-warning @ warning off
-: selftest ( -- error? )
- depth d# 16 < if false exit then
-
- .vertical-bars16 wait
- hgradient
-
- confirm-selftest?
-;
-warning !
-
-device-end
-
-." Starting final phase" cr
-after-runin
More information about the openfirmware
mailing list