osmo-st-core/Timer.st

"
 (C) 2011 by Holger Hans Peter Freyther
 All Rights Reserved

 This program is free software: you can redistribute it and/or modify
 it under the terms of the GNU Affero General Public License as
 published by the Free Software Foundation, either version 3 of the
 License, or (at your option) any later version.

 This program 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 Affero General Public License for more details.

 You should have received a copy of the GNU Affero General Public License
 along with this program.  If not, see <http://www.gnu.org/licenses/>.
"

Object subclass: Timer [
    | schedule timeout block |

    <category: 'OsmoCore-Timer'>
    <comment: 'This is a receipt for an active timer'>

    Timer class >> on: aSchedule [
        <category: 'creation'>
        ^ self new
            schedule: aSchedule;
            yourself
    ]

    timeout [
        <category: 'accessing'>
        ^ timeout
    ]

    schedule: aSchedule [
        <category: 'creation'>
        schedule := aSchedule.
    ]

    timeout: aTimeout [
        <category: 'creation'>
        timeout := aTimeout.
    ]

    block: aBlock [
        <category: 'creation'>
        block := aBlock
    ]

    fire [
        <category: 'execution'>
        block value
    ]

    cancel [
        <category: 'management'>
        "Remember that the timer is gone."
        schedule := nil.
    ]

    isCanceled [
        <category: 'management'>
        ^ schedule == nil.
    ]
]

Object subclass: TimerScheduler [
    | queue sem loop quit lastDelay |
    <category: 'OsmoCore-Timer'>
    <comment: 'I can help to fire things at the right time. Right now I
only work on seconds granularity because Time has no direct access to
milliseconds. Also I run a loop every second. I should use a Semaphore to
signal the process about a change of the closest time but it might be a
bit difficult to do this race free.'>

    TimerScheduler class >> instance [
        <category: 'singleton'>
        ^ Smalltalk at: #OsmoTimeScheduler ifAbsentPut: [TimerScheduler new].
    ]


    TimerScheduler class >> new [
        <category: 'private'>
        ^ super new
            initialize;
            addToBeFinalized;
            yourself
    ]

    finalize [
        <category: 'private'>
        quit := true.
    ]

    platformInit [
        <category: 'creation'>
        "Nothing for GST..."
    ]

    initialize [
        <category: 'private'>
        queue := SortedCollection sortBlock: [:a :b | a timeout < b timeout].
        sem := Semaphore forMutualExclusion.
        quit := false.
        self
            startLoop;
            platformInit.
    ]

    startLoop [
        <category: 'creation'>

        loop := [Processor activeProcess name: 'Osmo Timers'.
                 self runTimers] fork.
    ]

    scheduleInSeconds: aDelay block: aBlock [
        | sched |
        <category: 'schedule'>
        sched := (Timer on: self)
                    block: aBlock;
                    timeout: (DateTime now + (Duration milliseconds: 1000 * aDelay));
                    yourself.

        sem critical: [
            queue add: sched.
        ].

        ^ sched
    ]

    runTimers [
        <category: 'delay_loop'>

        [quit] whileFalse: [ | now |

            "Remember the last delay so we can interrupt it on image resume on Pharo"
            lastDelay := Delay forSeconds: 1.
            lastDelay wait.
            lastDelay := nil.

            now := DateTime now.
            OsmoDispatcher dispatchBlock: [self fireTimers: now].
        ]
    ]

    fireTimers: now [
        <category: 'private'>

        "Now execute the timers. One way or another this is crazy. If we have
        a long blocking application or a deadlock the timer queue will get
        stuck. But if we run this in a new process a later process might be run
        before this process, changing the order of the timers."
        "Only this process will remove items, this is why we can check isEmpty
        without having the lock"
        [queue isEmpty or: [queue first timeout > now]] whileFalse: [ | each |
            each := sem critical: [queue removeFirst].
            each isCanceled ifFalse: [
                [each fire] on: Error do: [:e |
                e logException:
                    ('Execution of timer failed: ', e messageText) area: #timer.
            ]].
        ]
    ]
]